initial

.gitignore

@@ -0,0 +1,7 @@
+/test*
+/logs/
+/modules/
+*.exe
+*.swp
+
+

callbacks/dispatch.tcl

@@ -0,0 +1,356 @@
+namespace eval shellspy::callbacks {
+    package require shellfilter
+    
+    
+  #each member of args - ist not itself a list - and cannot be treated as one.
+  #things like [concat {*}args] will generall break things further down the line
+    proc cmdshellb {args} {
+        shellfilter::log::open callback_cmdb {-syslog 127.0.0.1:514}
+        shellfilter::log::write callback_cmdb "cmdshellb got [llength $args] arguments"
+        shellfilter::log::write callback_cmdb "cmdshellb got  '$args'"
+        
+        if {[lindex $args 0] eq "cmdb"} {
+            set curlyparts [lrange $args 1 end]
+            shellfilter::log::write callback_cmdb "cmdshellb curlyparts  '$curlyparts'"
+            #we lose grouping info by joining like this..
+            #set tail [string trim [join $curlyparts " "]]
+            set tailinfo [shellfilter::list_element_info $curlyparts]
+            
+            shellfilter::log::write callback_cmdb "cmdshellb tailinfo  '$tailinfo'"
+            #e.g
+            #% set y {{"c:/test/etc"} true {'blah1'} {'blah 2'}}
+            #% lappend y  \\\\\\
+            #{"c:/test/etc"} true {'blah1'} {'blah 2'} \\\\\\
+            #% foreach i [shellfilter::list_element_info $y] {puts $i}
+            # 0
+            # wouldbrace 1 wouldescape 0 has_braces 0 has_inner_braces 0 apparentwrap doublequotes head_tail_chars {{"} {"}} head_tail_names {dq dq} len 13 difflen 2
+            # 1
+            # wouldbrace 0 wouldescape 0 has_braces 0 has_inner_braces 0 apparentwrap not-determined head_tail_chars {t e} head_tail_names {t e} len 4 difflen 0
+            # 2
+            # wouldbrace 0 wouldescape 0 has_braces 0 has_inner_braces 0 apparentwrap singlequotes head_tail_chars {' '} head_tail_names {sqote sqote} len 7 difflen 0
+            # 3
+            # wouldbrace 1 wouldescape 0 has_braces 0 has_inner_braces 0 apparentwrap singlequotes head_tail_chars {' '} head_tail_names {sqote sqote} len 8 difflen 2
+            # 4
+            # wouldbrace 0 wouldescape 1 has_braces 0 has_inner_braces 0 apparentwrap not-determined head_tail_chars {\\ \\} head_tail_names {\\ \\} len 3 difflen 3
+            
+            
+            #sample arglist - 7 items
+            #((c:\lua\luajit.exe
+            #C:\Users\sleek\vimfiles\plugged\vim-flog/lua/flog/graph_bin.lua
+            #__START
+            #true
+            #git -C C:/repo/3p/ansi-to-html --literal-pathspecs log --parents --topo-order --no-color --pretty=format:__START\%n\%h\%n\%p\%n\%D\%n\%ad\ \[\%h\]\ \{\%an\}\%d\ \%s --date=iso --no-merges --max-count=2000 -- )
+            #>
+            #C:\Users\sleek\AppData\Local\Temp\VRR6A67.tmp)
+            
+            
+            #complex method.. lists at levels..
+            set taillist [list]
+            set level 0 ;#bracket depth.. incr each opening bracket "("
+            set leveldict [dict create]
+            dict set leveldict 0 [list]
+            
+            #simpler method.. string
+            set output ""
+            dict for {idx info} $tailinfo {
+                set item [lindex $curlyparts $idx]
+                set itemlen [string length $item]
+                if {[dict get $info apparentwrap] eq "brackets"} {
+                    set chars [split $item ""]
+                    set opening [lsearch -all $chars "("]
+                    set closing [lsearch -all $chars ")"]
+                    if {[llength $opening] == [llength $closing]} {
+                        #dict lappend leveldict 0 $item ;#element individually wrapped in brackets and balanced, pass through
+                        append output "$item "
+                    } else {
+                        #robustness warning: we examine outer brackets only, and are ignoring that things like {((a)(b)} {((a)(b}
+                        #  are composed of multiple elements for now ..  as there should have been a space between the (a) & (b) elements anyway,
+                        #  in which case we would only see things like {((a)} or {(a}
+                        set ltrimmed [string trimleft $item "("]
+                        set countleft [expr {$itemlen - [string length $ltrimmed]}]
+                        
+                        set rtrimmed [string trimright $item ")"]
+                        set countright [expr {$itemlen - [string length $rtrimmed]}]
+                        
+                        #simpler method..
+                        append output "$item "
+                        
+                    }
+                } else {
+                    set lcharname [lindex [dict get $info head_tail_names] 0]
+                    set rcharname [lindex [dict get $info head_tail_names] 1]
+                    
+                    if {$lcharname eq "lbracket"} {
+                        set ltrimmed [string trimleft $item "("]
+                        set countleft [expr {$itemlen - [string length $ltrimmed]}]
+                        set braces [string repeat "(" $countleft]
+                        
+                        set testlist [list]
+                        lappend testlist $ltrimmed
+                        set testinfo [shellfilter::list_element_info $testlist]
+                        set testelement [dict get $testinfo 0]
+                        if {[dict get $testelement wouldbrace]} {
+                            #append output "${braces}\"$ltrimmed\" "
+                            append output "${braces} $ltrimmed "
+                        } else {
+                            append output "${braces} $ltrimmed "
+                        }
+                    
+                    } elseif {$rcharname eq "rbracket"} {
+                        set rtrimmed [string trimright $item ")" ]
+                        set countright [expr {$itemlen - [string length $rtrimmed]}]
+                        set braces [string repeat ")" $countright]
+                        set testlist [list]
+                        lappend testlist $rtrimmed
+                        set testinfo [shellfilter::list_element_info $testlist]
+                        set testelement [dict get $testinfo 0]
+                        if {[dict get $testelement wouldbrace]} {
+                            #append output "\"$rtrimmed\"${braces} "
+                            if {[string first " " $rtrimmed] > 0} {
+                                append output "\"$rtrimmed\" ${braces} "
+                            } else {
+                                append output "$rtrimmed ${braces} "
+                            }
+                        } else {
+                            append output "${rtrimmed} ${braces} "
+                        }
+                        
+                    
+                    } else {
+                        set testlist [list]
+                        lappend testlist $item
+                        set testinfo [shellfilter::list_element_info $testlist]
+                        set testelement [dict get $testinfo 0]
+                        if {[dict get $testelement wouldbrace]} {
+                            #append output "\"$item\" "
+                            if {[string first " " $item] > 0} {
+                                append output "\"$item\" "
+                            } else {
+                                append output "$item "
+                            }
+                        } else {
+                            append output "$item "
+                        }
+                    }
+                    
+                }
+            
+            }
+            shellfilter::log::write callback_cmdb "cmdshellb about to parse_cmd_brackets '$output'"
+            #$output now has quoted all items that 'wouldbrace' 
+            set curly_list [shellfilter::parse_cmd_brackets $output]
+            if {[llength $curly_list] == 1} {
+                #we expect the whole set of arguments was wrapped in a set of brackets
+                set curly_items [lindex $curly_list 0]
+            } else {
+                #unexpected.. root level of string had multiple bracketed sections
+                #try using the curly_list directly warn?
+                set curly_items $curly_list
+            }
+            #e.g
+            # ((c:\lua\luajit.exe -v) > C:\Users\sleek\AppData\Local\Temp\V7NCBF.tmp)
+            #=>
+            # {{{c:\lua\luajit.exe} -v} > {C:\Users\sleek\AppData\Local\Temp\V7NCBF.tmp}}
+            
+            #what is the proper way to flatten?
+            
+            set comspec [lindex $curly_items 0]
+            if {[llength $comspec] >1} {
+                set commandlist [concat $comspec [lrange $curly_items 1 end]]    
+            } else {
+                set commandlist $curly_items
+            }
+            
+            set commandlist [floghack_singlearg callback_cmdb {*}$commandlist]
+            return $commandlist
+        } else {
+            shellfilter::log::write callback_cmdb "first arg: [lindex $args 0] vs 'cmdb'"
+            error "first arg: [lindex $args 0] vs 'cmdb'"
+            #return $args
+        }
+    }
+    proc cmdshell {args} {
+        if {[catch {
+            set args [floghack_singlearg callback_cmdshell {*}$args]
+        } errMsg]} {
+            error "FLOGHACK callback_cmdshell error $errMsg"
+        }
+
+
+      #set args [concat [lindex $args 0] [lrange $args 1 end]]
+      return $args
+    }
+    proc cmdshelluc {args} {
+        if {[catch {
+            set args [floghack_singlearg callback_cmdshelluc {*}$args]
+        } errMsg]} {
+            error "FLOGHACK callback_cmdshelluc error $errMsg"
+        }
+
+        #set args [concat [lindex $args 0] [lrange $args 1 end]]
+        return $args
+    }
+  
+  proc powershell {args} {
+        if {[catch {
+            set args [floghack "callback_powershell" {*}$args]
+        } errMsg]} {
+            error "FLOGHACK callback_powershell error $errMsg"
+        }
+        return $args
+      
+  }
+  proc raw {args} {
+        if {[catch {
+            set args [floghack_singlearg "callback_raw" {*}$args]
+        } errMsg]} {
+            error "FLOGHACK callback_raw error $errMsg"
+        }
+      #set args [concat [split [lindex $args 0]] [lrange $args 1 end]] ;#definitely bad!
+      
+
+      return $args
+  }
+
+  #hack for c: drive - extend as necessary
+  #todo - customize! 
+  # various hacks may be necessary for home dirs temp files etc!
+  proc sh {args} {
+        if {[catch {
+            set args [floghack callback_sh {*}$args]
+        } errMsg]} {
+            error "FLOGHACK callback_sh error $errMsg"
+        }
+
+
+
+    set final [list]
+    foreach a $args {
+      if {[string match -nocase {*c:/*} $a]} {
+        set a [string map [list {c:/} {/c/}] $a]
+        lappend final $a
+      } elseif {[string match -nocase {*c:\\*} $a]} {
+        set a [string map [list \\ / ] $a]
+        set a [string map [list {c:/} {/c/} {C:/} {/C/}] $a]
+        lappend final $a 
+      } else {
+        lappend final $a
+      }
+    }
+    return $final
+  }
+  proc wsl {args} {
+    set args [floghack_singlearg callback_wsl {*}$args]
+    #wsl bash-style /mnt/c paths to be convertd
+    set args [convert_mnt_win {*}$args]
+    
+    #review - seems bad
+    #flatten first element which arrives wrapped
+    #set args [concat [lindex $args 0] [lrange $args 1 end]]
+    
+    
+    return $args
+  }
+  proc bash {args} {
+    set args [floghack callback_bash {*}$args]
+    return [convert_mnt_win {*}$args]
+  }
+
+
+
+  #helper functions
+  proc convert_mnt_win {args} {
+    set final [list]
+    foreach a $args {
+      if {[string match -nocase {*c:\\*} $a]} {
+         set a [string map [list \\ / ] $a]
+      }
+      #bash seems to be strict about lowercase /mnt/c
+      if {[string match -nocase {*c:/*} $a]} {
+        set a [string map [list {c:/} {/mnt/c/} {C:/} {/mnt/c/}] $a]
+      }
+      lappend final $a
+    }
+    shellfilter::log::write callback_convert_mnt_win "convert_mnt_win commandlist '$final'"
+    return $final
+  }
+
+  #when we get the git command and args together as one element in the commandlist
+  proc floghack_singlearg {logtag args} {
+     #return $args
+     shellfilter::log::write $logtag "floghack_singlearg got $logtag '$args'"
+     set newargs [list]
+     foreach a $args {
+        if {[string match "*pretty=format:__START*" $a]} {
+          set a [string map [list "pretty=format:__" "pretty=format:\"__"] $a]
+          set a [string map [list " --date=" "\" --date="] $a]
+          set a [string map [list \\ ""] $a] ;# a bad idea?
+          lappend newargs $a
+        } else {
+          lappend newargs $a
+        }
+     }
+     shellfilter::log::write $logtag "floghack_singlearg hacked commandlist '$newargs'"
+     return $newargs  
+  }
+
+
+  proc floghack {logtag args} {
+  
+    #return $args
+    shellfilter::log::write $logtag "floghack got [llength $args] args: '$args'"
+    set indent "    "
+    set i 0
+    foreach a $args {
+      shellfilter::log::write $logtag "floghack ${indent}$i $a"
+      incr i
+    }
+
+    #Flog/luajit hack
+    #wrong way
+    #if {[string first "pretty=format:__START" $args] > 0} {
+    #  set args [string map [list "pretty=format:" "pretty=format:'" " --date=" "' --date=" ] $args]
+    #}
+    set newargs [list]
+    
+    set pretty ""
+    set pstart [lsearch $args "--pretty=format:__START*"]
+    set pafter [lsearch $args "--date=*"]
+    if {$pstart > 0} {
+      set newargs [lrange $args 0 $pstart-1]
+      set parts [lrange $args $pstart $pafter-1]
+      set i 1
+      foreach p $parts {
+        if {$i == 1} {
+          set pretty [string map [list "format:__" "format:\"__"] $p]
+          #set pretty $p
+        } else {
+          append pretty " $p"
+        }
+        if {$i == [llength $parts]} {
+          append pretty "\""
+        }
+        incr i
+      }
+      set pretty [string map [list \\ ""] $pretty]
+      lappend newargs $pretty
+      #lappend newargs "--pretty=format:%h"
+      set newargs [concat $newargs [lrange $args $pafter end]] ;#concat of 2 lists.. should be ok
+    } else {
+      set newargs $args
+    }
+
+
+    shellfilter::log::write $logtag "floghack hacked commandlist '$newargs'"
+
+
+    return $newargs
+  }
+
+
+
+
+
+
+
+}

callbacks/parameters.tcl

@@ -0,0 +1,51 @@
+namespace eval shellspy::parameters {
+  proc cmdshellb {paramdict} {
+    return [commonset params_cmdshellb $paramdict]
+  }
+
+  
+  proc cmdshell {paramdict} {
+    return [commonset params_cmdshell $paramdict]
+  }
+
+  proc powershell {paramdict} {
+    return [commonset params_powershell $paramdict]
+  }
+
+  proc raw {paramdict} {
+    return [commonset params_raw $paramdict]
+  }
+
+  proc wsl {paramdict} {
+    return [commonset params_wsl $paramdict]
+  }
+  proc bash {paramdict} {
+    return [commonset params_bash $paramdict]
+  }
+
+  proc sh {paramdict} {
+    return [commonset params_sh $paramdict]
+  }
+
+  proc  commonset {logtag paramdict} {
+    #timeout for launched process
+    dict set paramdict -timeout 60000
+    #prefix for each stdout line - for debugging if this output being mixed with some other
+    dict set paramdict -outprefix ""
+    #prefix for each stderr line - also usually best left blank
+    dict set paramdict -errprefix ""
+    #put extra info to the log outputs (by default goes to syslog 127.0.0.1 514)
+    dict set paramdict -debug 0
+    dict set paramdict -outbuffering none
+    dict set paramdict -inbuffering none
+    #if at tail end of commandline there is a > or >> redirection to a file that contains 'temp'
+    # make a '_copy' version  e.g for something/temp/blah.tmp 
+    # create something/temp/blah_copy.tmp
+    # this is for pipelines where some other process deletes the original temp file but you want a copy
+    # to review/debug. 
+    dict set paramdict -copytempfile 1
+
+    shellfilter::log::write $logtag "base parameters: $paramdict"
+    return $paramdict
+  }
+}

scriptlib/ansi_count_per_second.tcl

@@ -0,0 +1,54 @@
+
+if {$::argc == 1} {
+   set persec $::argv 
+} else {
+   set persec 1
+}
+if {$persec > 1000} {
+  puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed"
+  flush stderr
+  after 500
+}
+#--- confg ---
+set newline_every_x_seconds 5
+#---
+chan configure stdout -blocking 1 -buffering none
+set counter 0
+set ms [expr {1000 / $persec}]
+set nl_every [expr {$persec * $newline_every_x_seconds}]
+
+proc schedule {} {
+    after idle [list after 0 ::emit]
+    tailcall after $::ms ::schedule
+}
+
+proc emit {} {
+    upvar ::counter c
+    puts -nonewline "\x1b\[1000D$c"
+
+    #if {($c > 1) && (($c % $::nl_every) == 0)} {
+    #    puts stdout $c
+    #    flush stdout
+    #} else {
+    #    puts -nonewline "\x1b\[1000D$c"
+    #}
+    #flush stdout
+    incr c
+}
+chan configure stdin -blocking 0 -buffering none
+chan event stdin readable [list apply {{chan} {
+    set chunk [chan read $chan]
+    if {[string length $chunk]} {
+        if {[string match "q*" [string tolower $chunk]]} {
+            set ::forever 0
+        }
+    }
+    if {[chan eof $chan]} {
+        chan event $chan readable {}
+    }
+}} stdin]
+
+schedule
+vwait ::forever
+
+puts "-done-"

scriptlib/showargs.tcl

@@ -0,0 +1,32 @@
+puts -nonewline stdout "info script\r\n"
+puts stdout "[info script]"
+puts stdout "::argc"
+puts stdout $::argc
+puts stdout "::argv"
+puts stdout "$::argv"
+puts stdout "NS"
+puts stdout "[namespace current]"
+
+if {[info exists ::test]} {
+    puts stdout "::test has existing value"
+    puts stdout "$::test"
+}
+
+puts stdout "setting ::test to showargs-ran"
+set ::test "showargs-ran"
+puts stdout "doing basic check of stdin for data"
+chan configure stdin -blocking 0
+set indata ""
+if {![chan eof stdin]} {
+    #set indata [read stdin]
+}
+if {[string length $indata]} {
+    puts stdout "read from stdin:"
+    puts stdout $indata
+} else {
+puts stdout "-no stdin data read-"
+}
+
+
+
+

scriptlib/stdout_per_second.tcl

@@ -0,0 +1,77 @@
+
+if {$::argc >= 1} {
+   set persec [lindex $::argv 0]
+} else {
+   set persec 1
+}
+if {$::argc == 2} {
+    set what [lindex $::argv 1]
+} else {
+    set what "."
+}
+
+if {$persec > 1000} {
+  puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed"
+  flush stderr
+  after 500
+}
+#--- confg ---
+set newline_every_x_seconds 5
+#---
+chan configure stdout -blocking 1 -buffering none
+set counter 0
+set ms [expr {1000 / $persec}]
+set nl_every [expr {$persec * $newline_every_x_seconds}]
+
+proc schedule {} {
+    if {$::forever_stdout_per_second} {
+        after idle [list after 0 ::emit]
+        tailcall after $::ms ::schedule
+    } else {
+        after idle [list ::the_end]
+    }
+}
+
+set ::forever_stdout_per_second 1
+
+proc the_end {} {
+    puts "-done-"
+    flush stdout
+    set ::done_stdout_per_second 1
+}
+
+proc emit {} {
+    upvar ::counter c
+    if {($c > 1) && (($c % $::nl_every) == 0)} {
+        puts -nonewline stdout " "
+        flush stdout
+        puts stderr $c
+        flush stderr
+    } else {
+        puts -nonewline stdout $::what
+    }
+    #flush stdout
+    incr c
+}
+chan configure stdin -blocking 0 -buffering none
+chan event stdin readable [list apply {{chan} {
+    set chunk [chan read $chan]
+    if {[string length $chunk]} {
+        if {[string match "*q*" [string tolower $chunk]]} {
+            set ::forever_stdout_per_second 0
+            chan event $chan readable {}
+            puts stdout "cancelling"
+        }
+    }
+    if {[chan eof $chan]} {
+        chan event $chan readable {}
+    }
+}} stdin]
+
+schedule
+vwait ::forever_stdout_per_second
+
+vwait ::done_stdout_per_second
+
+
+

src/make_punk86.tcl

@@ -0,0 +1,118 @@
+
+
+if {[lsearch $::argv -k] >= 0} {
+    set forcekill 1
+} else {
+    set forcekill 0
+}
+puts stdout "::argv  $::argv"
+
+set dirname [file normalize [file dirname [info script]]]
+
+if {![file exists $dirname/punk86.vfs]} {
+    puts stderr "missing $dirname/punk86.vfs"
+    exit 1
+}
+if {[file exists $dirname/punk86]} {
+    puts stderr "deleting existing $dirname/punk86"
+    file delete $dirname/punk86
+}
+
+puts stdout "building with sdx.."
+if {[catch {
+    exec sdx wrap punk86 -runtime tclkit86bi.exe -verbose
+    } result]} {
+    puts stderr "sdx wrap punk86 -runtime tclkit86bi.exe -verbose failed with msg: $result"
+} else {
+    puts stdout "ok - finished sdx"
+    set separator [string repeat = 40]
+    puts stdout $separator
+    puts stdout $result
+    puts stdout $separator
+}
+
+if {![file exists $dirname/punk86]} {
+    puts stderr "|err> build didn't seem to produce output at $dirname/punk86"
+    exit 2
+}
+
+if {![catch {
+        exec tasklist | grep punk86
+    } still_running]} {
+    puts stdout "found punk86 instances still running\n"
+    set count_killed 0
+    foreach ln [split $still_running \n] {
+        puts stdout "    $ln"
+        set pid [lindex $ln 1]
+        if {$forcekill} {
+            set killcmd [list taskkill /F /PID $pid]
+        } else {
+            set killcmd [list taskkill /PID $pid]
+        }
+        
+        puts stdout "    pid: $pid (attempting to kill now using '$killcmd')"
+        
+        if {[catch {
+                exec {*}$killcmd
+                } errMsg]} {
+            puts stderr "taskkill /PID $pid returned an error:"
+            puts stderr $errMsg
+            puts stderr "(try '[info script] -k' option to force kill)"
+            exit 4
+        } else {
+            puts stderr "taskkill /PID $pid ran without error"
+            incr count_killed
+        }
+    }
+    if {$count_killed > 0} {
+        puts stderr "\nKilled $count_killed processes. Waiting a short time before attempting to delete executable"
+        after 2000
+    }
+} else {
+    puts stderr "Ok.. no running punk processes found"
+}
+
+
+
+if {[file exists $dirname/punk86.exe]} {
+    puts stderr "deleting existing $dirname/punk86.exe"
+    if {[catch {
+        file delete $dirname/punk86.exe
+    } msg]} {
+        puts stderr "Failed to delete $dirname/punk86.exe"
+        exit 3
+    }
+}
+
+#is this test necessary?
+if {[file exists $dirname/punk86.exe]} {
+    puts stderr "deletion of $dirname/punk86.exe failed - locked?"
+    exit 3
+}
+
+file rename $dirname/punk86 $dirname/punk86.exe 
+after 500
+set deployment_folder [file dirname $dirname]
+
+if {[file exists $deployment_folder/punk86.exe]} {
+    puts stderr "deleting existing deployed at $deployment_folder/punk86.exe"
+    if {[catch {
+        file delete $deployment_folder/punk86.exe
+        } errMsg]} {
+        puts stderr "deletion of deployed version at $deployment_folder/punk86.exe failed: $errMsg"
+        exit 4
+    }
+}
+
+
+
+puts stdout "copying.."
+puts stdout "$dirname/punk86.exe"
+puts stdout "to:"
+puts stdout "$deployment_folder/punk86.exe"
+after 500
+file copy $dirname/punk86.exe $deployment_folder/punk86.exe
+
+puts stdout "done"
+
+

src/modules/#tarjar-tarjar-2.3/#z

@@ -0,0 +1,2 @@
+#This 2-line file marks the end of the Tcl-sourceable section of a tarjar. Do not remove the trailing ctrl-z character from this file.
+

src/modules/#tarjar-tarjar-2.3/CHANGES

@@ -0,0 +1,19 @@
+2010-03-05
+    - allow #tarjar-loadscript.tcl  (no package name or version number)
+
+2008-03-15 (tarpack)
+	- version 1.1.3
+	- modified for use in environments where ::env(HOME) is not available (certain operations such as 'file normalize ~' etc depend on it)
+
+2006-08-08 (tarpack)
+    - bump version to 1.1.2
+    - fix tarpack::wrap so that the 'scriptTidy' string doesn't force the wrapped package to be dependent on tarpack.
+        i.e call to 'tarpack::disconnect' now wrapped in test for 'tarpack'. 
+        This allows a tcl-only script to be wrapped with tarpack, but not require tarpack on deployment.
+
+2006-08-15 
+	- tarjar 1.0 created as a fork of tarpack 1.1.2 (which is to be abandoned as it's too close in name to 'starpack').
+
+2008-06-06
+	- tarjar 1.1
+	

src/modules/#tarjar-tarjar-2.3/DESCRIPTION.txt

@@ -0,0 +1,3 @@
+Identifier: tarjar
+Version: 2.3
+Rights: BSD

src/modules/#tarjar-tarjar-2.3/README.tarjar.txt

@@ -0,0 +1,11 @@
+A tarjar is a standard tar (ustar or gnu format)  archive which is also directly loadable as a Tcl module without requiring the tarball to be unarchived.
+
+When the tarjar is placed on the Tcl module-path it can be loaded with:
+package require <PackageName>
+Where the <PackageName> is the segment of the tarjar filename before the dash and version number.
+
+!NOTE! The tarjar can be unpacked in the same folder as the .tm file, in which case, the unpacked files will take precedence over the wrapped version.
+The wrapped (.tm) version however needs to remain in place to 'redirect' to the unwrapped version.
+
+
+

src/modules/#tarjar-tarjar-2.3/codesnippets/basic_loader.txt

@@ -0,0 +1,47 @@
+apply {code {
+    set scriptpath [file normalize [info script]]
+    if {[string match "#tarjar-loadscript*.tcl" [file tail $scriptpath]]} {
+        #jump up an extra dir level if we are within a #tarjar-loadscript file.
+        set mypath [file dirname [file dirname $scriptpath]]
+        set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #tarjar-<module>-<ver>
+    } else {
+        set mypath [file dirname $scriptpath]
+        set modver [file root [file tail [info script]]]
+    }
+    set mysegs [file split $mypath]
+    set overhang [list]
+    foreach libpath [tcl::tm::list] {
+        set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & /
+        if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} {
+            #mypath is below libpath
+            set overhang [lrange $mysegs [llength $libsegs]+1  end]
+            break
+        }
+    }
+    lassign [split $modver -] moduletail version
+    set ns [join [concat $overhang $moduletail] ::]
+    if {![catch {package require tarjar}]} {
+        ::tarjar::disconnect [info script]
+    }
+    package provide $ns $version
+    namespace eval $ns $code
+} ::} {
+    #
+    # Module procs here, where current namespace is that of the module.
+    # Package version can, if needed, be accessed as [uplevel 1 {set version}]
+    # Last element of module name: [uplevel 1 {set moduletail}]
+    # Full module name: [uplevel 1 {set ns}]
+    
+    #<modulecode>
+    #
+    #</modulecode>
+    
+    #<sourcefiles>
+    #
+    #</sourcefiles>
+    
+    #<loadfiles>
+    #
+    #</loadfiles>
+    
+}

src/modules/#tarjar-tarjar-2.3/codesnippets/full_loader.txt

@@ -0,0 +1,78 @@
+apply {code {
+    set scriptpath [file normalize [info script]]
+    if {[string match "#tarjar-loadscript*.tcl" [file tail $scriptpath]]} {
+        #jump up an extra dir level if we are within a #tarjar-loadscript file.
+        set mypath [file dirname [file dirname $scriptpath]]
+        set modver [string range [file tail [file dirname $scriptpath]] 8 end] ;# the containing folder is named #tarjar-<module>-<ver>
+    } else {
+        set mypath [file dirname $scriptpath]
+        set modver [file root [file tail [info script]]]
+    }
+    set mysegs [file split $mypath]
+    set mysegs_rejoined [file join $mysegs /]
+    set mysegs_count [llength $mysegs]
+    set overhang [list]
+    foreach libpath [tcl::tm::list] {
+        set libsegs [file split $libpath] ;#split and rejoin with '/' because sometimes module paths may have mixed \ & /
+        if {$mysegs_rejoined eq [file join [lrange $libsegs 0 $mysegs_count] /]} {
+            #mypath is below libpath
+            set overhang [lrange $mysegs [llength $libsegs]+1  end]
+            break
+        }
+    }
+    lassign [split $modver -] moduletail version
+    set ns [join [concat $overhang $moduletail] ::]
+    if {![catch {package require tarjar}]} {
+        lassign [::tarjar::glob ${moduletail}/load/[::tarjar::platform::generic] *] _ok libs ;#assume all files are loadable..
+        if {[llength $libs] > 0} {
+            foreach lname $libs {
+                tarjar::load ${moduletail}/load/[::tarjar::platform::generic]/$lname -from [info script]
+            }
+        } else {
+            lassign [::tarjar::glob ${moduletail}/load *] _ok binfolders
+            set some_bin_exists false ;#keep track of whether there is at least one binary in the archive for some architecture.
+            set architectures_supported [list]
+            foreach fldr $binfolders {
+                lassign [::tarjar::glob ${moduletail}/load/$fldr *] _ok binfile
+                if {[llength $binfile] > 0} {
+                    set some_bin_exists true
+                    lappend architectures_supported $fldr
+                }
+            }
+            if {[llength $architectures_supported] > 0} {
+                puts stderr "platform [tarjar::platform::generic] not supported by the tarjar load-script. (archive contains binaries for:[join $architectures_supported ,])"
+            }
+        }
+        #load all other .tcl files in the *tarjar base* folder - ie those not explicitly wrapped in the {modulename} folder 
+        #!todo -  use a manifest to determine load order?
+        set basefolder [file dirname $moduletail]
+        lassign [::tarjar::glob $basefolder *.tcl] _ok sourcefiles
+        foreach f $sourcefiles {
+            if {![string match "#*" $f]} {
+                namespace eval $ns [list tarjar::source $basefolder/$f]
+            }
+        }
+        ::tarjar::disconnect [info script]
+    }
+    package provide $ns $version
+    namespace eval $ns $code
+} ::} {
+    #
+    # Module procs here, where current namespace is that of the module.
+    # Package version can, if needed, be accessed as [uplevel 1 {set version}]
+    # Last element of module name: [uplevel 1 {set moduletail}]
+    # Full module name: [uplevel 1 {set ns}]
+    
+    #<modulecode>
+    #
+    #</modulecode>
+    
+    #<sourcefiles>
+    #
+    #</sourcefiles>
+    
+    #<loadfiles>
+    #
+    #</loadfiles>
+    
+}

src/modules/#tarjar-tarjar-2.3/template/README.tarjar.txt

@@ -0,0 +1,11 @@
+A tarjar is a standard tar (ustar or gnu format) archive which is also directly loadable as a Tcl module without requiring the tarball to be unarchived.
+
+When the tarjar is placed on the Tcl module-path it can be loaded with:
+package require <PackageName>
+Where the <PackageName> is the segment of the tarjar filename before the dash and version number.
+
+!NOTE! The tarjar can be unpacked in the same folder as the .tm file, in which case, the unpacked files will take precedence over the wrapped version.
+The wrapped version however needs to remain in place to 'redirect' to the unwrapped version.
+
+
+

src/modules/#tarjar-tarjar-2.3/todo.txt

@@ -0,0 +1,3 @@
+split tarjar read functionality into separate file/namespace.
+Work out how to make tarjar self-hosting. ie wrap next version of tarjar using current one.
+(use a 'rollup' of the read-code in the generated loadscript?)

src/modules/argp-0.2.tm

@@ -0,0 +1,259 @@
+
+# Tcl parser for optional arguments in function calls and
+#  commandline arguments
+#
+# (c) 2001 Bastien Chevreux
+
+#  Index of exported commands
+#     - argp::registerArgs
+#     - argp::setArgDefaults
+#     - argp::setArgsNeeded
+#     - argp::parseArgs
+
+#  Internal commands
+#     - argp::CheckValues
+
+# See end of file for an example on how to use
+
+package provide argp 0.2
+
+namespace eval argp {
+    variable Optstore
+    variable Opttypes {
+	boolean integer double string
+    }
+
+    namespace export {[a-z]*}
+}
+
+
+proc argp::registerArgs { func arglist } {
+    variable Opttypes
+    variable Optstore
+
+    set parentns [string range [uplevel 1 [list namespace current]] 2 end]
+    if { $parentns != "" } {
+	append caller $parentns :: $func
+    } else {
+	set caller $func
+    }
+    set cmangled [string map {:: _} $caller]
+
+    #puts $parentns
+    #puts $caller
+    #puts $cmangled
+
+    set Optstore(keys,$cmangled) {}
+    set Optstore(deflist,$cmangled) {}
+    set Optstore(argneeded,$cmangled) {}
+
+    foreach arg $arglist {
+	foreach {opt type default allowed} $arg {
+	    set optindex [lsearch -glob $Opttypes $type*]
+	    if { $optindex < 0} {
+		return -code error "$caller, unknown type $type while registering arguments.\nAllowed types: [string trim $Opttypes]"
+	    }
+	    set type [lindex $Opttypes $optindex]
+
+	    lappend Optstore(keys,$cmangled) $opt 
+	    set Optstore(type,$opt,$cmangled) $type
+	    set Optstore(default,$opt,$cmangled) $default
+	    set Optstore(allowed,$opt,$cmangled) $allowed
+	    lappend Optstore(deflist,$cmangled) $opt $default
+	}
+    }
+
+    if { [catch {CheckValues $caller $cmangled $Optstore(deflist,$cmangled)} res]} {
+	 return -code error "Error in declaration of optional arguments.\n$res"
+    }
+}
+
+proc argp::setArgDefaults { func arglist } {
+    variable Optstore
+
+    set parentns [string range [uplevel 1 [list namespace current]] 2 end]
+    if { $parentns != "" } {
+	append caller $parentns :: $func
+    } else {
+	set caller $func
+    }
+    set cmangled [string map {:: _} $caller]
+
+    if {![info exists Optstore(deflist,$cmangled)]} {
+	return -code error "Arguments for $caller not registered yet."
+    }
+    set Optstore(deflist,$cmangled) {}
+    foreach {opt default} $arglist {
+	if {![info exists Optstore(default,$opt,$cmangled)]} {
+	    return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
+	}
+	set Optstore(default,$opt,$cmangled) $default
+    }
+
+    # set the new defaultlist
+    foreach opt $Optstore(keys,$cmangled) {
+	lappend Optstore(deflist,$cmangled) $opt $Optstore(default,$opt,$cmangled)
+    }
+}
+
+proc argp::setArgsNeeded { func arglist } {
+    variable Optstore
+
+    set parentns [string range [uplevel 1 [list namespace current]] 2 end]
+    if { $parentns != "" } {
+	append caller $parentns :: $func
+    } else {
+	set caller $func
+    }
+    set cmangled [string map {:: _} $caller]
+
+    #append caller $parentns :: $func
+    #set cmangled ${parentns}_$func
+
+    if {![info exists Optstore(deflist,$cmangled)]} {
+	return -code error "Arguments for $caller not registered yet."
+    }
+
+    set Optstore(argneeded,$cmangled) {}
+    foreach opt $arglist {
+	if {![info exists Optstore(default,$opt,$cmangled)]} {
+	    return -code error "$caller, unknown option $opt, must be one of: $Optstore(keys,$cmangled)"
+	}
+	lappend Optstore(argneeded,$cmangled) $opt 
+    }
+}
+
+
+proc argp::parseArgs { args } {
+    variable Optstore
+
+    if {[llength $args] == 0} {
+	upvar args a opts o
+    } else {
+	upvar args a [lindex $args 0] o
+    }
+
+    if { [ catch { set caller [lindex [info level -1] 0]}]} {
+	set caller "main program"
+	set cmangled ""
+    } else {
+	set cmangled [string map {:: _} $caller]
+    }
+
+    if {![info exists Optstore(deflist,$cmangled)]} {
+	return -code error "Arguments for $caller not registered yet."
+    }
+
+    # set the defaults
+    array set o $Optstore(deflist,$cmangled)
+
+    # but unset the needed arguments
+    foreach key $Optstore(argneeded,$cmangled) {
+	catch { unset o($key) }
+    }
+
+    foreach {key val} $a {
+	if {![info exists Optstore(type,$key,$cmangled)]} {
+	    return -code error "$caller, unknown option $key, must be one of: $Optstore(keys,$cmangled)"
+	}
+	switch -exact -- $Optstore(type,$key,$cmangled) {
+	    boolean -
+	    integer {
+		if { $val == "" } {
+		    return -code error "$caller, $key empty string is not $Optstore(type,$key,$cmangled) value."
+		}
+		if { ![string is $Optstore(type,$key,$cmangled) $val]} {
+		    return -code error "$caller, $key $val is not $Optstore(type,$key,$cmangled) value."
+		}
+	    }
+	    double {
+		if { $val == "" } {
+		    return -code error "$caller, $key empty string is not double value."
+		}
+		if { ![string is double $val]} {
+		    return -code error "$caller, $key $val is not double value."
+		}
+		if { [string is integer $val]} {
+		    set val [expr {$val + .0}]
+		}
+	    }
+	    default {
+	    }
+	}
+	set o($key) $val
+    }
+
+    foreach key $Optstore(argneeded,$cmangled) {
+	if {![info exists o($key)]} {
+	    return -code error "$caller, needed argument $key was not given."
+	}
+    }
+
+    if { [catch { CheckValues $caller $cmangled [array get o]} err]} {
+	return -code error $err
+    }
+
+    return
+}
+
+
+proc argp::CheckValues { caller cmangled checklist } {
+    variable Optstore
+
+    #puts "Checking $checklist"
+
+    foreach {key val} $checklist {
+	if { [llength $Optstore(allowed,$key,$cmangled)] > 0 } {
+	    switch -exact -- $Optstore(type,$key,$cmangled) {
+		string {
+		    if { [lsearch $Optstore(allowed,$key,$cmangled) $val] < 0} {
+			return -code error "$caller, $key $val is not in allowed values: $Optstore(allowed,$key,$cmangled)"
+		    }
+		}
+		double -
+		integer {
+		    set found 0
+		    foreach range $Optstore(allowed,$key,$cmangled) {
+			if {[llength $range] == 1} {
+			    if { $val == [lindex $range 0] } {
+				set found 1
+				break
+			    }
+			} elseif {[llength $range] == 2} {
+			    set low [lindex $range 0]
+			    set high [lindex $range 1]
+
+			    if { ![string is integer $low] \
+				    && [string compare "-" $low] != 0} {
+				return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a lower value range that is not integer and not ´-´: $range"
+			    }
+			    if { ![string is integer $high] \
+				    && [string compare "+" $high] != 0} {
+				return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has a upper value range that is not integer and not ´+´: $range"
+			    }
+			    if {[string compare "-" $low] == 0} {
+				if { [string compare "+" $high] == 0 \
+					|| $val <= $high } {
+				    set found 1
+				    break
+				}
+			    }
+			    if { $val >= $low } {
+				if {[string compare "+" $high] == 0 \
+					|| $val <= $high } {
+				    set found 1
+				    break
+				}
+			    }
+			} else {
+			    return -code error "$caller, $key of type $Optstore(type,$key,$cmangled) has an allowed value range containing more than 2 elements: $range"
+			}
+		    }
+		    if { $found == 0 } {
+			return -code error "$caller, $key $val is not covered by allowed ranges: $Optstore(allowed,$key,$cmangled)"
+		    }
+		}
+	    }
+	}
+    }
+}

src/modules/overtype-1.3.tm

@@ -0,0 +1,157 @@
+
+package provide [lassign {overtype 1.3} pkg ver]$pkg [namespace eval $pkg[set pkg {}] {list [variable version $ver[set ver {}]]$version}]
+
+#Julian Noble <julian@precisium.com.au> - 2003 
+#Released under standard 'BSD license' conditions.
+#
+#todo - ellipsis truncation indicator for center,right
+
+
+namespace eval overtype {
+	namespace export *
+}
+proc overtype::about {} {
+	return "Simple text formatting. Author JMN. BSD-License"
+}
+
+
+proc overtype::left {args} {
+	# @c overtype starting at left (overstrike) 
+	# @c can/should we use something like this?: 'format "%-*s" $len $overtext 
+
+	if {[llength $args] < 2} {
+		error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
+	}
+	foreach {undertext overtext} [lrange $args end-1 end] break
+
+	set opt(-ellipsis)		0
+	set opt(-ellipsistext)	{...}
+	set opt(-overflow)	0
+	array set opt [lrange $args 0 end-2]
+
+	
+	set len [string length $undertext]
+	set overlen [string length $overtext]
+	set diff [expr {$overlen - $len}]
+	if {$diff > 0} {
+		if {$opt(-overflow)} {
+			return $overtext
+		} else {
+			if {$opt(-ellipsis)} {
+				return [overtype::right [string range $overtext 0 [expr {$len -1}]] $opt(-ellipsistext)]
+			} else {
+				return [string range $overtext 0 [expr {$len -1}]]
+			}
+		}
+	} else {
+		
+		return "$overtext[string range $undertext $overlen end]"
+	}
+}
+
+# test - use more tcl8.5 features.
+proc overtype::left2 {args} {
+	# @c overtype starting at left (overstrike) 
+	# @c can/should we use something like this?: 'format "%-*s" $len $overtext 
+
+	if {[llength $args] < 2} {
+		error {usage: ?-overflow [1|0]? ?-ellipsis [1|0]? ?-ellipsistext ...? undertext overtext}
+	}
+	foreach {undertext overtext} [lrange $args end-1 end] break
+
+	set opt(-ellipsis)		0
+	set opt(-ellipsistext)	{...}
+	set opt(-overflow)	0
+	array set opt [lrange $args 0 end-2]
+
+	
+	set len [string length $undertext]
+	set overlen [string length $overtext]
+	set diff [expr {$overlen - $len}]
+	if {$diff > 0} {
+		if {$opt(-overflow)} {
+			return $overtext
+		} else {
+			if {$opt(-ellipsis)} {
+				return [overtype::right [string range $overtext 0 $len-1] $opt(-ellipsistext)]
+			} else {
+				return [string range $overtext 0 $len-1 ]
+			}
+		}
+	} else {
+		#return "$overtext[string range $undertext $overlen end]"
+		return [string replace $undertext 0 $overlen-1 $overtext]
+	}
+}
+proc overtype::centre {args} {
+	if {[llength $args] < 2} {
+		error {usage: ?-bias [left|right]?  ?-overflow [1|0]? undertext overtext}
+	}
+	foreach {undertext overtext} [lrange $args end-1 end] break
+
+	set opt(-bias)		left
+	set opt(-overflow)	0
+	array set opt [lrange $args 0 end-2]
+	
+
+	set olen [string length $overtext]
+	set ulen [string length $undertext]
+    	set diff [expr {$ulen - $olen}]
+	if {$diff > 0} {
+		set half [expr {round(int($diff / 2))}]
+		if {[string match right $opt(-bias)]} {
+			if {[expr {2 * $half}] < $diff} {
+				incr half
+			}
+		}
+		
+		set rhs [expr {$diff - $half - 1}]
+		set lhs [expr {$half - 1}]
+
+		set a [string range $undertext 0 $lhs]
+		set b $overtext
+		set c [string range $undertext end-$rhs end]
+		return $a$b$c
+	} else {
+		if {$diff < 0} {
+			if {$opt(-overflow)} {
+				return $overtext
+			} else {
+				return [string range $overtext 0 [expr {$ulen - 1}]]
+			}
+		} else {
+			return $overtext
+		}
+	}
+}
+
+proc overtype::right {args} {
+	# @d !todo - implement overflow, length checks etc
+
+	if {[llength $args] < 2} {
+		error {usage: ?-overflow [1|0]? undertext overtext}
+	}
+	foreach {undertext overtext} [lrange $args end-1 end] break
+
+	set opt(-overflow)	0
+	array set opt [lrange $args 0 end-2]
+
+
+	set olen [string length $overtext]
+	set ulen [string length $undertext]
+
+	if {$opt(-overflow)} {
+		return [string range $undertext 0 end-$olen]$overtext
+	} else {
+		if {$olen > $ulen} {	
+		  	set diff [expr {$olen - $ulen}]
+		  	return [string range $undertext 0 end-$olen][string range $overtext 0 end-$diff]
+		} else {
+			return [string range $undertext 0 end-$olen]$overtext
+		}
+	}
+}
+
+namespace eval overtype {
+	interp alias {} ::overtype::center {} ::overtype::centre
+}

src/modules/platform-1.0.17.tm

@@ -0,0 +1,428 @@
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Overview
+
+# Heuristics to assemble a platform identifier from publicly available
+# information. The identifier describes the platform of the currently
+# running tcl shell. This is a mixture of the runtime environment and
+# of build-time properties of the executable itself.
+#
+# Examples:
+# <1> A tcl shell executing on a x86_64 processor, but having a
+#   wordsize of 4 was compiled for the x86 environment, i.e. 32
+#   bit, and loaded packages have to match that, and not the
+#   actual cpu.
+#
+# <2> The hp/solaris 32/64 bit builds of the core cannot be
+#   distinguished by looking at tcl_platform. As packages have to
+#   match the 32/64 information we have to look in more places. In
+#   this case we inspect the executable itself (magic numbers,
+#   i.e. fileutil::magic::filetype).
+#
+# The basic information used comes out of the 'os' and 'machine'
+# entries of the 'tcl_platform' array. A number of general and
+# os/machine specific transformation are applied to get a canonical
+# result.
+#
+# General
+# Only the first element of 'os' is used - we don't care whether we
+# are on "Windows NT" or "Windows XP" or whatever.
+#
+# Machine specific
+# % amd64  -> x86_64
+# % arm*   -> arm
+# % sun4*  -> sparc
+# % ia32*  -> ix86
+# % intel  -> ix86
+# % i*86*  -> ix86
+# % Power* -> powerpc
+# % x86_64 + wordSize 4 => x86 code
+#
+# OS specific
+# % AIX are always powerpc machines
+# % HP-UX 9000/800 etc means parisc
+# % linux has to take glibc version into account
+# % sunos -> solaris, and keep version number
+#
+# NOTE: A platform like linux glibc 2.3, which can use glibc 2.2 stuff
+# has to provide all possible allowed platform identifiers when
+# searching search. Ditto a solaris 2.8 platform can use solaris 2.6
+# packages. Etc. This is handled by the other procedure, see below.
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+namespace eval ::platform {}
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+# -- platform::generic
+#
+# Assembles an identifier for the generic platform. It leaves out
+# details like kernel version, libc version, etc.
+
+proc ::platform::generic {} {
+    global tcl_platform
+
+    set plat [string tolower [lindex $tcl_platform(os) 0]]
+    set cpu  $tcl_platform(machine)
+
+    switch -glob -- $cpu {
+	sun4* {
+	    set cpu sparc
+	}
+	intel -
+	ia32* -
+	i*86* {
+	    set cpu ix86
+	}
+	x86_64 {
+	    if {$tcl_platform(wordSize) == 4} {
+		# See Example <1> at the top of this file.
+		set cpu ix86
+	    }
+	}
+	ppc -
+	"Power*" {
+	    set cpu powerpc
+	}
+	"arm*" {
+	    set cpu arm
+	}
+	ia64 {
+	    if {$tcl_platform(wordSize) == 4} {
+		append cpu _32
+	    }
+	}
+    }
+
+    switch -glob -- $plat {
+	windows {
+	    if {$tcl_platform(platform) == "unix"} {
+		set plat cygwin
+	    } else {
+		set plat win32
+	    }
+	    if {$cpu eq "amd64"} {
+		# Do not check wordSize, win32-x64 is an IL32P64 platform.
+		set cpu x86_64
+	    }
+	}
+	sunos {
+	    set plat solaris
+	    if {[string match "ix86" $cpu]} {
+		if {$tcl_platform(wordSize) == 8} {
+		    set cpu x86_64
+		}
+	    } elseif {![string match "ia64*" $cpu]} {
+		# sparc
+		if {$tcl_platform(wordSize) == 8} {
+		    append cpu 64
+		}
+	    }
+	}
+	darwin {
+	    set plat macosx
+	    # Correctly identify the cpu when running as a 64bit
+	    # process on a machine with a 32bit kernel
+	    if {$cpu eq "ix86"} {
+		if {$tcl_platform(wordSize) == 8} {
+		    set cpu x86_64
+		}
+	    }
+	}
+	aix {
+	    set cpu powerpc
+	    if {$tcl_platform(wordSize) == 8} {
+		append cpu 64
+	    }
+	}
+	hp-ux {
+	    set plat hpux
+	    if {![string match "ia64*" $cpu]} {
+		set cpu parisc
+		if {$tcl_platform(wordSize) == 8} {
+		    append cpu 64
+		}
+	    }
+	}
+	osf1 {
+	    set plat tru64
+	}
+	default {
+	    set plat [lindex [split $plat _-] 0]
+	}
+    }
+
+    return "${plat}-${cpu}"
+}
+
+# -- platform::identify
+#
+# Assembles an identifier for the exact platform, by extending the
+# generic identifier. I.e. it adds in details like kernel version,
+# libc version, etc., if they are relevant for the loading of
+# packages on the platform.
+
+proc ::platform::identify {} {
+    global tcl_platform
+
+    set id [generic]
+    regexp {^([^-]+)-([^-]+)$} $id -> plat cpu
+
+    switch -- $plat {
+	solaris {
+	    regsub {^5} $tcl_platform(osVersion) 2 text
+	    append plat $text
+	    return "${plat}-${cpu}"
+	}
+	macosx {
+	    set major [lindex [split $tcl_platform(osVersion) .] 0]
+	    if {$major > 19} {
+		set minor [lindex [split $tcl_platform(osVersion) .] 1]
+		incr major -9
+		append plat $major.[expr {$minor - 1}]
+	    } else {
+		incr major -4
+		append plat 10.$major
+		return "${plat}-${cpu}"
+	    }
+	    return "${plat}-${cpu}"
+	}
+	linux {
+	    # Look for the libc*.so and determine its version
+	    # (libc5/6, libc6 further glibc 2.X)
+
+	    set v unknown
+
+	    # Determine in which directory to look. /lib, or /lib64.
+	    # For that we use the tcl_platform(wordSize).
+	    #
+	    # We could use the 'cpu' info, per the equivalence below,
+	    # that however would be restricted to intel. And this may
+	    # be a arm, mips, etc. system. The wordsize is more
+	    # fundamental.
+	    #
+	    # ix86   <=> (wordSize == 4) <=> 32 bit ==> /lib
+	    # x86_64 <=> (wordSize == 8) <=> 64 bit ==> /lib64
+	    #
+	    # Do not look into /lib64 even if present, if the cpu
+	    # doesn't fit.
+
+	    # TODO: Determine the prefixes (i386, x86_64, ...) for
+	    # other cpus.  The path after the generic one is utterly
+	    # specific to intel right now.  Ok, on Ubuntu, possibly
+	    # other Debian systems we may apparently be able to query
+	    # the necessary CPU code. If we can't we simply use the
+	    # hardwired fallback.
+
+	    switch -exact -- $tcl_platform(wordSize) {
+		4 {
+		    lappend bases /lib
+		    if {[catch {
+			exec dpkg-architecture -qDEB_HOST_MULTIARCH
+		    } res]} {
+			lappend bases /lib/i386-linux-gnu
+		    } else {
+			# dpkg-arch returns the full tripled, not just cpu.
+			lappend bases /lib/$res
+		    }
+		}
+		8 {
+		    lappend bases /lib64
+		    if {[catch {
+			exec dpkg-architecture -qDEB_HOST_MULTIARCH
+		    } res]} {
+			lappend bases /lib/x86_64-linux-gnu
+		    } else {
+			# dpkg-arch returns the full tripled, not just cpu.
+			lappend bases /lib/$res
+		    }
+		}
+		default {
+		    return -code error "Bad wordSize $tcl_platform(wordSize), expected 4 or 8"
+		}
+	    }
+
+	    foreach base $bases {
+		if {[LibcVersion $base -> v]} break
+	    }
+
+	    append plat -$v
+	    return "${plat}-${cpu}"
+	}
+    }
+
+    return $id
+}
+
+proc ::platform::LibcVersion {base _->_ vv} {
+    upvar 1 $vv v
+    set libclist [lsort [glob -nocomplain -directory $base libc*]]
+
+    if {![llength $libclist]} { return 0 }
+
+    set libc [lindex $libclist 0]
+
+    # Try executing the library first. This should suceed
+    # for a glibc library, and return the version
+    # information.
+
+    if {![catch {
+	set vdata [lindex [split [exec $libc] \n] 0]
+    }]} {
+	regexp {version ([0-9]+(\.[0-9]+)*)} $vdata -> v
+	foreach {major minor} [split $v .] break
+	set v glibc${major}.${minor}
+	return 1
+    } else {
+	# We had trouble executing the library. We are now
+	# inspecting its name to determine the version
+	# number. This code by Larry McVoy.
+
+	if {[regexp -- {libc-([0-9]+)\.([0-9]+)} $libc -> major minor]} {
+	    set v glibc${major}.${minor}
+	    return 1
+	}
+    }
+    return 0
+}
+
+# -- platform::patterns
+#
+# Given an exact platform identifier, i.e. _not_ the generic
+# identifier it assembles a list of exact platform identifier
+# describing platform which should be compatible with the
+# input.
+#
+# I.e. packages for all platforms in the result list should be
+# loadable on the specified platform.
+
+# << Should we add the generic identifier to the list as well ? In
+#    general it is not compatible I believe. So better not. In many
+#    cases the exact identifier is identical to the generic one
+#    anyway.
+# >>
+
+proc ::platform::patterns {id} {
+    set res [list $id]
+    if {$id eq "tcl"} {return $res}
+
+    switch -glob --  $id {
+	solaris*-* {
+	    if {[regexp {solaris([^-]*)-(.*)} $id -> v cpu]} {
+		if {$v eq ""} {return $id}
+		foreach {major minor} [split $v .] break
+		incr minor -1
+		for {set j $minor} {$j >= 6} {incr j -1} {
+		    lappend res solaris${major}.${j}-${cpu}
+		}
+	    }
+	}
+	linux*-* {
+	    if {[regexp {linux-glibc([^-]*)-(.*)} $id -> v cpu]} {
+		foreach {major minor} [split $v .] break
+		incr minor -1
+		for {set j $minor} {$j >= 0} {incr j -1} {
+		    lappend res linux-glibc${major}.${j}-${cpu}
+		}
+	    }
+	}
+	macosx-powerpc {
+	    lappend res macosx-universal
+	}
+	macosx-x86_64 {
+	    lappend res macosx-i386-x86_64
+	}
+	macosx-ix86 {
+	    lappend res macosx-universal macosx-i386-x86_64
+	}
+	macosx*-*    {
+	    # 10.5+,11.0+
+	    if {[regexp {macosx([^-]*)-(.*)} $id -> v cpu]} {
+
+		switch -exact -- $cpu {
+		    ix86    {
+			lappend alt i386-x86_64
+			lappend alt universal
+		    }
+		    x86_64  {
+			if {[lindex [split $::tcl_platform(osVersion) .] 0] < 19} {
+			    set alt i386-x86_64
+			} else {
+			    set alt {}
+			}
+		    }
+		    arm  {
+			lappend alt x86_64
+		    }
+		    default { set alt {} }
+		}
+
+		if {$v ne ""} {
+		    foreach {major minor} [split $v .] break
+
+		    set res {}
+		    if {$major eq 11} {
+			# Add 11.0 to 11.minor to patterns.
+			for {set j $minor} {$j >= 0} {incr j -1} {
+			    lappend res macosx${major}.${j}-${cpu}
+			    foreach a $alt {
+				lappend res macosx${major}.${j}-$a
+			    }
+			}
+			set major 10
+			set minor 15
+		    }
+		    # Add 10.5 to 10.minor to patterns.
+		    for {set j $minor} {$j >= 5} {incr j -1} {
+			if {$cpu ne "arm"} {
+			    lappend res macosx${major}.${j}-${cpu}
+			}
+			foreach a $alt {
+			    lappend res macosx${major}.${j}-$a
+			}
+		    }
+
+		    # Add unversioned patterns for 10.3/10.4 builds.
+		    lappend res macosx-${cpu}
+		    foreach a $alt {
+			lappend res macosx-$a
+		    }
+		} else {
+		    # No version, just do unversioned patterns.
+		    foreach a $alt {
+			lappend res macosx-$a
+		    }
+		}
+	    } else {
+		# no v, no cpu ... nothing
+	    }
+	}
+    }
+    lappend res tcl ; # Pure tcl packages are always compatible.
+    return $res
+}
+
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide platform 1.0.17
+
+# ### ### ### ######### ######### #########
+## Demo application
+
+if {[info exists argv0] && ($argv0 eq [info script])} {
+    puts ====================================
+    parray tcl_platform
+    puts ====================================
+    puts Generic\ identification:\ [::platform::generic]
+    puts Exact\ identification:\ \ \ [::platform::identify]
+    puts ====================================
+    puts Search\ patterns:
+    puts *\ [join [::platform::patterns [::platform::identify]] \n*\ ]
+    puts ====================================
+    exit 0
+}

src/modules/platform/shell-1.1.4.tm

@@ -0,0 +1,241 @@
+
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Overview
+
+# Higher-level commands which invoke the functionality of this package
+# for an arbitrary tcl shell (tclsh, wish, ...). This is required by a
+# repository as while the tcl shell executing packages uses the same
+# platform in general as a repository application there can be
+# differences in detail (i.e. 32/64 bit builds).
+
+# ### ### ### ######### ######### #########
+## Requirements
+
+package require platform
+namespace eval ::platform::shell {}
+
+# ### ### ### ######### ######### #########
+## Implementation
+
+# -- platform::shell::generic
+
+proc ::platform::shell::generic {shell} {
+    # Argument is the path to a tcl shell.
+
+    CHECK $shell
+    LOCATE base out
+
+    set     code {}
+    # Forget any pre-existing platform package, it might be in
+    # conflict with this one.
+    lappend code {package forget platform}
+    # Inject our platform package
+    lappend code [list source $base]
+    # Query and print the architecture
+    lappend code {puts [platform::generic]}
+    # And done
+    lappend code {exit 0}
+
+    set arch [RUN $shell [join $code \n]]
+
+    if {$out} {file delete -force $base}
+    return $arch
+}
+
+# -- platform::shell::identify
+
+proc ::platform::shell::identify {shell} {
+    # Argument is the path to a tcl shell.
+
+    CHECK $shell
+    LOCATE base out
+
+    set     code {}
+    # Forget any pre-existing platform package, it might be in
+    # conflict with this one.
+    lappend code {package forget platform}
+    # Inject our platform package
+    lappend code [list source $base]
+    # Query and print the architecture
+    lappend code {puts [platform::identify]}
+    # And done
+    lappend code {exit 0}
+
+    set arch [RUN $shell [join $code \n]]
+
+    if {$out} {file delete -force $base}
+    return $arch
+}
+
+# -- platform::shell::platform
+
+proc ::platform::shell::platform {shell} {
+    # Argument is the path to a tcl shell.
+
+    CHECK $shell
+
+    set     code {}
+    lappend code {puts $tcl_platform(platform)}
+    lappend code {exit 0}
+
+    return [RUN $shell [join $code \n]]
+}
+
+# ### ### ### ######### ######### #########
+## Internal helper commands.
+
+proc ::platform::shell::CHECK {shell} {
+    if {![file exists $shell]} {
+	return -code error "Shell \"$shell\" does not exist"
+    }
+    if {![file executable $shell]} {
+	return -code error "Shell \"$shell\" is not executable (permissions)"
+    }
+    return
+}
+
+proc ::platform::shell::LOCATE {bv ov} {
+    upvar 1 $bv base $ov out
+
+    # Locate the platform package for injection into the specified
+    # shell. We are using package management to find it, whereever it
+    # is, instead of using hardwired relative paths. This allows us to
+    # install the two packages as TMs without breaking the code
+    # here. If the found package is wrapped we copy the code somewhere
+    # where the spawned shell will be able to read it.
+
+    # This code is brittle, it needs has to adapt to whatever changes
+    # are made to the TM code, i.e. the provide statement generated by
+    # tm.tcl
+
+    set pl [package ifneeded platform [package require platform]]
+    set base [lindex $pl end]
+
+    set out 0
+    if {[lindex [file system $base]] ne "native"} {
+	set temp [TEMP]
+	file copy -force $base $temp
+	set base $temp
+	set out 1
+    }
+    return
+}
+
+proc ::platform::shell::RUN {shell code} {
+    set     c [TEMP]
+    set    cc [open $c w]
+    puts  $cc $code
+    close $cc
+
+    set e [TEMP]
+
+    set code [catch {
+        exec $shell $c 2> $e
+    } res]
+
+    file delete $c
+
+    if {$code} {
+	append res \n[read [set chan [open $e r]]][close $chan]
+	file delete $e
+	return -code error "Shell \"$shell\" is not executable ($res)"
+    }
+
+    file delete $e
+    return $res
+}
+
+proc ::platform::shell::TEMP {} {
+    set prefix platform
+
+    # This code is copied out of Tcllib's fileutil package.
+    # (TempFile/tempfile)
+
+    set tmpdir [DIR]
+
+    set chars "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
+    set nrand_chars 10
+    set maxtries 10
+    set access [list RDWR CREAT EXCL TRUNC]
+    set permission 0600
+    set channel ""
+    set checked_dir_writable 0
+    set mypid [pid]
+    for {set i 0} {$i < $maxtries} {incr i} {
+ 	set newname $prefix
+ 	for {set j 0} {$j < $nrand_chars} {incr j} {
+ 	    append newname [string index $chars \
+		    [expr {int(rand()*62)}]]
+ 	}
+	set newname [file join $tmpdir $newname]
+ 	if {[file exists $newname]} {
+ 	    after 1
+ 	} else {
+ 	    if {[catch {open $newname $access $permission} channel]} {
+ 		if {!$checked_dir_writable} {
+ 		    set dirname [file dirname $newname]
+ 		    if {![file writable $dirname]} {
+ 			return -code error "Directory $dirname is not writable"
+ 		    }
+ 		    set checked_dir_writable 1
+ 		}
+ 	    } else {
+ 		# Success
+		close $channel
+ 		return [file normalize $newname]
+ 	    }
+ 	}
+    }
+    if {$channel ne ""} {
+ 	return -code error "Failed to open a temporary file: $channel"
+    } else {
+ 	return -code error "Failed to find an unused temporary file name"
+    }
+}
+
+proc ::platform::shell::DIR {} {
+    # This code is copied out of Tcllib's fileutil package.
+    # (TempDir/tempdir)
+
+    global tcl_platform env
+
+    set attempdirs [list]
+
+    foreach tmp {TMPDIR TEMP TMP} {
+	if { [info exists env($tmp)] } {
+	    lappend attempdirs $env($tmp)
+	}
+    }
+
+    switch $tcl_platform(platform) {
+	windows {
+	    lappend attempdirs "C:\\TEMP" "C:\\TMP" "\\TEMP" "\\TMP"
+	}
+	macintosh {
+	    set tmpdir $env(TRASH_FOLDER)  ;# a better place?
+	}
+	default {
+	    lappend attempdirs \
+		[file join / tmp] \
+		[file join / var tmp] \
+		[file join / usr tmp]
+	}
+    }
+
+    lappend attempdirs [pwd]
+
+    foreach tmp $attempdirs {
+	if { [file isdirectory $tmp] && [file writable $tmp] } {
+	    return [file normalize $tmp]
+	}
+    }
+
+    # Fail if nothing worked.
+    return -code error "Unable to determine a proper directory for temporary files"
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide platform::shell 1.1.4

src/modules/shellthread-1.6.tm

@@ -0,0 +1,595 @@
+#package require logger
+
+package provide shellthread [namespace eval shellthread {
+  variable version
+  set version 1.6
+}]
+
+
+package require Thread
+
+namespace eval shellthread {
+
+  proc iso8601 {{tsmicros ""}} {
+    if {$tsmicros eq ""} {
+        set tsmicros [clock micros]
+    } else {
+        set microsnow [clock micros]
+        if {[string length $tsmicros] != [string length $microsnow]} {
+            error "iso8601 requires 'clock micros' or empty string to create timestamp"
+        }
+    }
+    set seconds [expr {$tsmicros / 1000000}]
+    return [clock format $seconds  -format "%Y-%m-%d_%H-%M-%S"]
+  }
+}
+
+namespace eval shellthread::worker {
+    variable settings
+    variable sysloghost_port
+    variable sock
+    variable logfile ""
+    variable fd
+    variable client_ids [list]
+    variable ts_start_micros
+    variable errorlist [list]
+    variable inpipe ""
+
+    proc bgerror {args} {
+       variable errorlist
+       lappend errorlist $args
+    }
+    proc send_errors_now {tidcli} {
+      variable errorlist
+      thread::send -async $tidcli [list shellthread::manager::report_worker_errors [list worker_tid [thread::id] errors $errorlist]]
+    }
+    proc add_client_tid {tidcli} {
+      variable client_ids
+      if {$tidcli ni $client_ids} {
+        lappend client_ids $tidcli
+      }
+    }
+    proc init {tidclient start_m settingsdict} {
+        variable sysloghost_port
+        variable logfile
+        variable settings
+        interp bgerror {} shellthread::worker::bgerror
+        package require overtype
+        variable client_ids
+        variable ts_start_micros
+        lappend client_ids $tidclient
+        set ts_start_micros $start_m
+
+        set defaults [list -raw 0 -file "" -syslog "" -direction out]
+        set settings [dict merge $defaults $settingsdict]
+
+        set syslog [dict get $settings -syslog]
+        if {[string length $syslog]} {
+            lassign [split $syslog :] s_host s_port
+            set sysloghost_port [list $s_host $s_port]
+        } else {
+            set sysloghost_port ""
+        }
+        if {[catch {package require udp} errm]} {
+            #disable rather than bomb and interfere with any -file being written
+            set sysloghost_port ""
+        }
+
+        set logfile [dict get $settings -file]
+    }
+
+    proc start_pipe_read {source readchan args} {
+        #assume 1 inpipe for now
+        variable inpipe
+        variable sysloghost_port
+        variable logfile
+        set defaults [dict create -buffering \uFFFF ]
+        set opts [dict merge $defaults $args]
+        if {[dict exists $opts -readbuffering]} {
+            set readbuffering [dict get $opts -readbuffering]
+        } else {
+            if {[dict get $opts -buffering] eq "\uFFFF"} {
+                #get buffering setting from the channel as it was set prior to thread::transfer
+                set readbuffering [chan configure $readchan -buffering]
+            } else {
+                set readbuffering [dict get $opts -buffering]
+                chan configure $readchan -buffering $readbuffering
+            }
+        }
+        if {[dict exists $opts -writebuffering]} {
+            set writebuffering [dict get $opts -writebuffering]
+        } else {
+            if {[dict get $opts -buffering] eq "\uFFFF"} {
+                set writebuffering line
+                #set writebuffering [chan configure $writechan -buffering]
+            } else {
+                set writebuffering [dict get $opts -buffering]
+                #can configure $writechan -buffering $writebuffering
+            }
+        }
+
+        chan configure $readchan -translation lf
+
+        if {$readchan ni [chan names]} {
+            error "shellthread::worker::start_pipe_read - inpipe not configured. Use shellthread::manager::set_pipe_read_from_client to thread::transfer the pipe end"    
+        }
+        set inpipe $readchan
+        #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO\n" line
+        chan configure $readchan -blocking 0
+        #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO2 readbuffering: $readbuffering syslog $sysloghost_port filename $logfile" line
+
+        set waitvar ::shellthread::worker::wait($inpipe,[clock micros])
+        chan event $readchan readable [list apply {{chan source waitfor readbuffering writebuffering} {
+           if {$readbuffering eq "line"} {
+               set chunksize [chan gets $chan chunk]
+               if {$chunksize >= 0} {
+                   if {![chan eof $chan]} {
+                        ::shellthread::worker::log pipe 0 - $source - info $chunk\n $writebuffering 
+                   } else {
+                       ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering 
+                   }
+               }
+           } else {
+               set chunk [chan read $chan]
+               ::shellthread::worker::log pipe 0 - $source - info $chunk $writebuffering 
+           } 
+           if {[chan eof $chan]} {
+               chan event $chan readable {}
+               set $waitfor "pipe"
+               chan close $chan
+           }
+        }} $readchan $source $waitvar $readbuffering $writebuffering] 
+        #::shellthread::worker::log $inpipe 0 - $source - info "START PIPE READ HELLO3 vwaiting on $waitvar\n" line
+        vwait $waitvar
+    }
+
+    proc start_pipe_write {source writechan args} {
+        variable outpipe
+        set defaults [dict create -buffering \uFFFF ]
+        set opts [dict merge $defaults $args]
+        
+        #todo!
+        set readchan stdin
+        
+        if {[dict exists $opts -readbuffering]} {
+            set readbuffering [dict get $opts -readbuffering]
+        } else {
+            if {[dict get $opts -buffering] eq "\uFFFF"} {
+                set readbuffering [chan configure $readchan -buffering]
+            } else {
+                set readbuffering [dict get $opts -buffering]
+                chan configure $readchan -buffering $readbuffering
+            }
+        }
+        if {[dict exists $opts -writebuffering]} {
+            set writebuffering [dict get $opts -writebuffering]
+        } else {
+            if {[dict get $opts -buffering] eq "\uFFFF"} {
+                #nothing explicitly set - take from transferred channel
+                set writebuffering [chan configure $writechan -buffering]
+            } else {
+                set writebuffering [dict get $opts -buffering]
+                can configure $writechan -buffering $writebuffering
+            }
+        }
+        
+        if {$writechan ni [chan names]} {
+            error "shellthread::worker::start_pipe_write - outpipe not configured. Use shellthread::manager::set_pipe_write_to_client to thread::transfer the pipe end"    
+        }
+        set outpipe $writechan
+        chan configure $readchan -blocking 0
+        chan configure $writechan -blocking 0
+        set waitvar ::shellthread::worker::wait($outpipe,[clock micros])
+        
+        chan event $readchan readable [list apply {{chan writechan source waitfor readbuffering} {
+            if {$readbuffering eq "line"} {
+                set chunksize [chan gets $chan chunk]
+                if {$chunksize >= 0} {
+                    if {![chan eof $chan]} {
+                        puts $writechan $chunk
+                    } else {
+                        puts -nonewline $writechan $chunk
+                    }
+                }
+            } else {
+                set chunk [chan read $chan]
+                puts -nonewline $writechan $chunk
+            }
+            if {[chan eof $chan]} {
+                chan event $chan readable {}
+                set $waitfor "pipe"
+                chan close $writechan 
+                if {$chan ne "stdin"} {
+                    chan close $chan
+                }
+            }
+        }} $readchan $writechan $source $waitvar $readbuffering]
+
+        vwait $waitvar
+    }
+
+
+    proc _initsock {} {
+      variable sysloghost_port
+      variable sock
+      if {[string length $sysloghost_port]} {
+        if {[catch {fconfigure $sock} state]} {
+          set sock [udp_open]
+          fconfigure $sock -buffering none -translation binary
+          fconfigure $sock -remote $sysloghost_port
+        }
+      }
+    } 
+    proc _reconnect {} {
+        variable sock
+        catch {close $sock}
+        _initsock
+        return [fconfigure $sock] 
+    }
+
+    proc send_info {client_tid ts_sent source msg} {
+        set ts_received [clock micros]
+        set lag_micros [expr {$ts_received - $ts_sent}]
+        set lag [expr {$lag_micros / 1000000.0}] ;#lag as x.xxxxxx seconds
+        
+        log $client_tid $ts_sent $lag $source - info $msg line 1
+    }
+    proc log {client_tid ts_sent lag source service level msg writebuffering {islog 0}} {
+        variable sock
+        variable fd
+        variable sysloghost_port
+        variable logfile
+        variable settings
+
+        set logchunk $msg
+
+        if {![dict get $settings -raw]} {
+            set tail_crlf 0
+            set tail_lf 0
+            set tail_cr 0
+            #for cooked  - always remove the trailing newline  before splitting.. 
+            #
+            #note that if we got our data from reading a non-line-buffered binary channel - then this naive line splitting will not split neatly for mixed line-endings.
+            #
+            #Possibly not critical as cooked is for logging and we are still preserving all \r and \n chars - but review and consider implementing a better split
+            #but add it back exactly as it was afterwards 
+            #we can always split on \n - and any adjacent \r will be preserved in the rejoin
+            set lastchar [string range $logchunk end end]
+            if {[string range $logchunk end-1 end] eq "\r\n"} {
+                set tail_crlf 1
+                set logchunk [string range $logchunk 0 end-2]
+            } else {
+                if {$lastchar eq "\n"} {
+                    set tail_lf 1
+                    set logchunk [string range $logchunk 0 end-1]
+                } elseif {$lastchar eq "\r"} {
+                    #\r line-endings are obsolete..and unlikely... and ugly as they can hide characters on the console. but we'll pass through anyway.
+                    set tail_cr 1
+                    set logchunk [string range $logchunk 0 end-1]
+                } else {
+                    #possibly a single line with no linefeed.. or has linefeeds only in the middle
+                }
+            }
+
+            if {$ts_sent != 0} {
+                set micros [lindex [split [expr {$ts_sent / 1000000.0}] .] end]
+                set time_info [::shellthread::iso8601 $ts_sent].$micros
+                #set time_info "${time_info}+$lag"
+                set lagfp "+[format %f $lag]"
+            } else {
+                #from pipe - no ts_sent/lag info available
+                set time_info ""
+                set lagfp ""
+            }
+
+            set idtail [string range $client_tid end-8 end] ;#enough for display purposes id - mostly zeros anyway
+            set col0 [string repeat " " 9]
+            set col1 [string repeat " " 27]
+            set col2 [string repeat " " 11]
+            set col3 [string repeat " " 20]
+            #do not columnize the final data column or append to tail - or we could muck up the crlf integrity
+
+            lassign [list [overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 $lagfp] [overtype::left $col3 $source]] c0 c1 c2 c3 
+
+            #split on \n no matter the actual line-ending in use
+            #shouldn't matter as long as we don't add anything at the end of the line other than the raw data
+            #ie - don't quote or add spaces
+            set lines [split $logchunk \n] 
+            
+            set i 1
+            set outlines [list]
+            foreach ln $lines {
+                if {$i == 1} {
+                    lappend outlines "$c0 $c1 $c2 $c3 $ln"
+                } else {
+                    lappend outlines "$c0 $c1 $col2 $c3 $ln"
+                }
+                incr i
+            }
+            if {$tail_lf} {
+                set logchunk "[join $outlines \n]\n"
+            } elseif {$tail_crlf} {
+                set logchunk "[join $outlines \r\n]\r\n"
+            } elseif {$tail_cr} {
+                set logchunk "[join $outlines \r]\r"
+            } else {
+                #no trailing linefeed
+                set logchunk [join $outlines \n] 
+
+            }
+
+            #set logchunk "[overtype::left $col0 $idtail] [overtype::left $col1 $time_info] [overtype::left $col2 "+$lagfp"] [overtype::left $col3 $source] $msg"
+        }
+        
+        if {[string length $sysloghost_port]} {
+            _initsock
+            catch {puts -nonewline $sock $logchunk}
+        }
+        #todo - sockets etc?
+        if {[string length $logfile]} {
+            #todo - setting to maintain open filehandle and reduce io.
+            # possible settings for buffersize - and maybe logrotation, although this could be left to client
+            #for now - default to safe option of open/close each write despite the overhead.
+            set fd [open $logfile a]
+            chan configure $fd -translation auto -buffering $writebuffering
+            #whether line buffered or not - by now our logchunk includes newlines
+            puts -nonewline $fd $logchunk
+            close $fd
+        }
+    }
+
+    # - withdraw just this client 
+    proc finish {tidclient} {
+      variable client_ids
+      if {($tidclient in $clientids) && ([llength $clientids] == 1)} {
+          terminate $tidclient
+      } else {
+         set posn [lsearch $client_ids $tidclient]
+         set client_ids [lreplace $clientids $posn $posn]
+      }
+    }
+
+    #allow any client to terminate
+    proc terminate {tidclient} {
+        variable sock
+        variable client_ids
+        if {$tidclient in $client_ids} {
+            catch {close $sock}
+            set client_ids [list]
+            return 1
+        } else {
+            return 0
+        }
+    }
+
+
+}
+
+
+namespace eval shellthread::manager {
+    variable workers [dict create]
+    variable worker_errors [list]
+
+    variable log_threads
+
+    #new datastructure regarding workers and sourcetags required.
+    #one worker can service multiple sourcetags - but each sourcetag may be used by multiple threads too.
+    #generally each thread will use a specific sourcetag - but we may have pools doing similar things which log to same destination.
+    #
+    #As a convention we may use a sourcetag for the thread which started the worker that isn't actually used for logging - but as a common target for joins
+    #If the thread which started the thread calls leave_worker with that 'primary' sourcetag it means others won't be able to use that target - which seems reasonable.
+    #If another thread want's to maintain joinability beyond the span provided by the starting client,
+    #it can join with both the primary tag and a tag it will actually use for logging.
+    #A thread can join the logger with any existingtag - not just the 'primary' 
+    #(which is arbitrary anyway. It will usually be the first in the list - but may be unsubscribed by clients and disappear)
+    proc join_worker {client_tid existingtag sourcetaglist} {
+        #todo - allow a source to piggyback on existing worker by referencing one of the sourcetags already using the worker
+    }
+    proc leave_worker {client_tid sourcetaglist} {
+        #todo
+        #unsub this client_tid from the sourcetags in the sourcetaglist. if no more client_tids exist for sourcetag, remove sourcetag,
+        #if no more sourcetags - close worker
+    }
+    #it is up to caller to use a unique sourcetag (e.g by prefixing with own thread::id etc)
+    # This allows multiple threads to more easily write to the same named sourcetag if necessary
+    # todo - change sourcetag for a list of tags which will be handled by the same thread. e.g for multiple threads logging to same file 
+    #
+    # todo - some protection mechanism for case where target is a file to stop creation of multiple worker threads writing to same file.
+    # Even if we use open fd,close fd wrapped around writes.. it is probably undesirable to have multiple threads with same target  
+    # On the other hand socket targets such as UDP can happily be written to by multiple threads.
+    # For now the mechanism is that a call to new_worker (rename to open_worker?) will join the same thread if a sourcetag matches.. 
+    # but, as sourcetags can get removed(unsubbed via leave_worker) this doesn't guarantee two threads with same -file settings won't fight.
+    # Also.. the settingsdict is ignored when joining with a tag that exists.. this is problematic.. e.g logrotation where previous file still being written by existing worker
+    # todo - rename 'sourcetag' concept to 'targettag' ?? the concept is a mixture of both.. it is somewhat analagous to a syslog 'facility' 
+    # probably new_worker should disallow auto-joining and we allow different workers to handle same tags simultaneously to support overlap during logrotation etc.
+    proc new_worker {sourcetaglist {settingsdict {}}} {
+        variable workers
+        set ts_start [clock micros]
+        set tidclient [thread::id]
+        set sourcetag [lindex $sourcetaglist 0] ;#todo - use all
+
+        if {[dict exists $workers $sourcetag]} {
+           set winfo [dict get $workers $sourcetag]
+           if {[thread::exists [dict get $winfo tid]]} {
+              #add our client-info to existing worker thread
+              dict lappend winfo list_client_tids $tidclient
+              dict set workers $sourcetag $winfo  ;#writeback
+              return [dict get $winfo tid]
+           }
+        }
+        #set ts_start [::shellthread::iso8601]
+        set tidworker [thread::create -preserved]
+        set init_script [string map [list %ts_start% $ts_start %mp% [tcl::tm::list] %ap% $::auto_path %tidcli% $tidclient %sd% $settingsdict] {
+            #set tclbase [file dirname [file dirname [info nameofexecutable]]]
+            #set tcllib $tclbase/lib
+            #if {$tcllib ni $::auto_path} {
+            #    lappend ::auto_path $tcllib
+            #}
+           
+            set ::settingsinfo [dict create %sd%]  
+            #if the executable running things is something like a tclkit,
+            # then it's likely we will need to use the caller's auto_path and tcl::tm::list to find things
+            #The caller can tune the thread's package search by providing a settingsdict
+            if {![dict exists $::settingsinfo tcl_tm_list]} {
+                tcl::tm::add %mp%
+            } else {
+                tcl::tm::remove {*}[tcl::tm::list]
+                tcl::tm::add {*}[dict get $::settingsinfo tcl_tm_list]
+            }
+            if {![dict exists $::settingsinfo auto_path]} {
+                set ::auto_path [list %ap%]
+            } else {
+                set ::auto_path [dict get $::settingsinfo auto_path]
+            }
+
+            package require Thread
+            package require shellthread
+            if {![catch {::shellthread::worker::init %tidcli% %ts_start% $::settingsinfo} errmsg]} {
+              unset ::settingsinfo
+              set ::shellthread_init "ok"
+            } else {
+              unset ::settingsinfo
+              set ::shellthread_init "err $errmsg"
+            }
+        }]
+
+        thread::send -async $tidworker $init_script
+        #thread::send $tidworker $init_script
+        set winfo [dict create tid $tidworker list_client_tids [list $tidclient] ts_start $ts_start ts_end_list [list]]
+        dict set workers $sourcetag $winfo
+        return $tidworker
+    }
+
+    proc set_pipe_read_from_client {tag_pipename worker_tid rchan args} {
+        variable workers
+        if {![dict exists $workers $tag_pipename]} {
+            error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename not found"
+        }
+        set match_worker_tid [dict get $workers $tag_pipename tid]
+        if {$worker_tid ne $match_worker_tid} {
+            error "workerthread::manager::set_pipe_read_from_client source/pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'"
+        }
+        #buffering set during channel creation will be preserved on thread::transfer
+        thread::transfer $worker_tid $rchan
+        #start_pipe_read will vwait - so we have to send async
+        thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_read $tag_pipename $rchan]
+        #client may start writing immediately - but presumably it will buffer in fifo2
+    }
+
+    proc set_pipe_write_to_client {tag_pipename worker_tid wchan args} {
+        variable workers
+        if {![dict exists $workers $tag_pipename]} {
+            error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename not found"
+        }
+        set match_worker_tid [dict get $workers $tag_pipename tid]
+        if {$worker_tid ne $match_worker_tid} {
+            error "workerthread::manager::set_pipe_write_to_client pipename $tag_pipename workert_tid mismatch '$worker_tid' vs existing:'$match_worker_tid'"
+        }
+        #buffering set during channel creation will be preserved on thread::transfer
+        thread::transfer $worker_tid $wchan
+        thread::send -async $worker_tid [list ::shellthread::worker::start_pipe_write $tag_pipename $wchan]
+    }
+
+    proc write_log {source msg args} {
+        variable workers 
+        set ts_micros_sent [clock micros]
+        set defaults [list -async 1 -level info]
+        set opts [dict merge $defaults $args]
+
+        if {[dict exists $workers $source]} {
+            set tidworker [dict get $workers $source tid]
+            if {![thread::exists $tidworker]} {
+                set tidworker [new_worker $source]
+            }
+        } else {
+            #auto create with no requirement to call new_worker.. warn?
+            set tidworker [new_worker $source]
+        }
+        set client_tid [thread::id]
+        if {[dict get $opts -async]} {
+            thread::send -async $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg]
+        } else {
+            thread::send $tidworker [list ::shellthread::worker::send_info $client_tid $ts_micros_sent $source $msg]
+        }
+    } 
+    proc report_worker_errors {errdict} {
+       variable workers
+       set reporting_tid [dict get $errdict worker_tid]
+       dict for {src srcinfo} $workers {
+          if {[dict get $srcinfo tid] eq $reporting_tid} {
+            dict set srcinfo errors [dict get $errdict errors]
+            dict set workers $src $srcinfo ;#writeback updated
+            break
+          }
+       }
+    }
+    proc close_worker {source {timeout 2500}} {
+        variable workers
+        variable worker_errors
+        set ts_now [clock micros]
+        #puts stderr "close_worker $source"
+        if {[dict exists $workers $source]} {
+            set tidworker [dict get $workers $source tid]
+            set ts_end_list [dict get $workers $source ts_end_list]
+            if {[llength $ts_end_list]} {
+              set last_end_ts [lindex $ts_end_list end]
+              if {[expr {(($tsnow - $last_end_ts) / 1000) >= $timeout}]} {
+                lappend ts_end_list $ts_now
+                dict set workers $source ts_end_list $ts_end_list
+              } else {
+                #existing close in progress.. assume it will work
+                return
+              }
+            }
+
+            if {[thread::exists $tidworker]} {
+                #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source still running.. terminating"
+                set timeoutarr($source) 0
+                after $timeout  [list set timeoutarr($source) 2]
+
+                thread::send -async $tidworker [list shellthread::worker::send_errors_now [thread::id]]
+                thread::send -async $tidworker [list shellthread::worker::terminate [thread::id]] timeoutarr($source)
+
+                #thread::send -async $tidworker [string map [list %tidclient% [thread::id]] {
+                #    shellthread::worker::terminate %tidclient%
+                #}] timeoutarr($source)
+                
+                vwait timeoutarr($source)
+                #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE1"
+
+                thread::release $tidworker
+                #puts stderr "shellthread::manager::close_worker: thread $tidworker for source $source DONE2"
+                if {[dict exists $workers $source errors]} {
+                    set errlist [dict get $workers $source errors]
+                    if {[llength $errlist]} {
+                        lappend worker_errors [list $source [dict get $workers $source]]
+                    }
+                }
+                dict unset workers $source
+            }
+        }
+        #puts stdout "close_worker $source - end"
+    }
+
+    #worker errors only available for a source after close_worker called on that source
+    #It is possible for there to be multiple entries for a source because new_worker can be called multiple times with same sourcetag,
+    # e.g if a thread 
+    proc get_and_clear_errors {source} {
+      variable worker_errors
+      set source_errors [lsearch -all -inline -index 0        $worker_errors $source]
+      set worker_errors [lsearch -all -inline -index 0 -not   $worker_errors $source]
+      return $source_errors
+    }
+
+
+}
+
+
+
+
+
+
+
+
+
+

src/punk86.vfs/lib/app-punk/pkgIndex.tcl

@@ -0,0 +1,3 @@
+
+  package ifneeded app-punk 1.0 [list source [file join $dir repl.tcl]]
+

src/punk86.vfs/lib/app-punk/repl.tcl

@@ -0,0 +1,820 @@
+#temp
+package provide app-punk 1.0
+
+set stdin_info [chan configure stdin]
+if {[dict exists $stdin_info -inputmode]} {
+    #this is the only way I currently know to detect console on windows.. doesn't work on Alma linux. 
+    # tcl_interactive used by repl to determine if stderr output prompt to be printed.
+    # (that way, piping commands into stdin should not produce prompts for each command)
+    set tcl_interactive 1
+}
+#however, the -mode option only seems to appear on linux when a terminal exists..
+if {[dict exists $stdin_info -mode]} {
+    set tcl_interactive 1
+}
+
+#give up for now
+set tcl_interactive 1
+
+proc todo {} {
+    puts "tcl History"
+
+
+}
+tcl::tm::add [pwd]/modules
+
+package require shellfilter
+package require Thread
+set outdevice [shellfilter::stack::new punkout -settings {-tag "punkout" -buffering none -raw 1 -syslog 127.0.0.1:514 -file "c:/repo/jn/shellspy/logs/repl-exec-stdout.txt"}]
+set out [dict get $outdevice localchan]
+set errdevice [shellfilter::stack::new punkerr -settings {-tag "punkerr" -buffering none -raw 1 -syslog 127.0.0.1:514 -file "c:/repo/jn/shellspy/logs/repl-exec-stderr.txt"}]
+set err [dict get $errdevice localchan]
+#
+#set indevice [shellfilter::stack::new commandin -settings {-tag "commandin" -readbuffering line -writebuffering none -raw 1 -direction in}]
+#set program_read_stdin_pipe   [dict get $indevice localchan]
+
+
+
+# unknown --
+# This procedure is called when a Tcl command is invoked that doesn't
+# exist in the interpreter.  It takes the following steps to make the
+# command available:
+#
+#	1. See if the autoload facility can locate the command in a
+#	   Tcl script file.  If so, load it and execute it.
+#	2. If the command was invoked interactively at top-level:
+#	    (a) see if the command exists as an executable UNIX program.
+#		If so, "exec" the command.
+#	    (b) see if the command requests csh-like history substitution
+#		in one of the common forms !!, !<number>, or ^old^new.  If
+#		so, emulate csh's history substitution.
+#	    (c) see if the command is a unique abbreviation for another
+#		command.  If so, invoke the command.
+#
+# Arguments:
+# args -	A list whose elements are the words of the original
+#		command, including the command name.
+
+proc unknown args {
+    variable ::tcl::UnknownPending
+    global auto_noexec auto_noload env tcl_interactive errorInfo errorCode
+
+    if {[info exists errorInfo]} {
+	set savedErrorInfo $errorInfo
+    }
+    if {[info exists errorCode]} {
+	set savedErrorCode $errorCode
+    }
+
+    set name [lindex $args 0]
+    if {![info exists auto_noload]} {
+	#
+	# Make sure we're not trying to load the same proc twice.
+	#
+	if {[info exists UnknownPending($name)]} {
+	    return -code error "self-referential recursion\
+		    in \"unknown\" for command \"$name\""
+	}
+	set UnknownPending($name) pending
+	set ret [catch {
+		auto_load $name [uplevel 1 {::namespace current}]
+	} msg opts]
+	unset UnknownPending($name)
+	if {$ret != 0} {
+	    dict append opts -errorinfo "\n    (autoloading \"$name\")"
+	    return -options $opts $msg
+	}
+	if {![array size UnknownPending]} {
+	    unset UnknownPending
+	}
+	if {$msg} {
+	    if {[info exists savedErrorCode]} {
+		set ::errorCode $savedErrorCode
+	    } else {
+		unset -nocomplain ::errorCode
+	    }
+	    if {[info exists savedErrorInfo]} {
+		set errorInfo $savedErrorInfo
+	    } else {
+		unset -nocomplain errorInfo
+	    }
+	    set code [catch {uplevel 1 $args} msg opts]
+	    if {$code ==  1} {
+		#
+		# Compute stack trace contribution from the [uplevel].
+		# Note the dependence on how Tcl_AddErrorInfo, etc.
+		# construct the stack trace.
+		#
+		set errInfo [dict get $opts -errorinfo]
+		set errCode [dict get $opts -errorcode]
+		set cinfo $args
+		if {[string length [encoding convertto utf-8 $cinfo]] > 150} {
+		    set cinfo [string range $cinfo 0 150]
+		    while {[string length [encoding convertto utf-8 $cinfo]] > 150} {
+			set cinfo [string range $cinfo 0 end-1]
+		    }
+		    append cinfo ...
+		}
+		set tail "\n    (\"uplevel\" body line 1)\n    invoked\
+			from within\n\"uplevel 1 \$args\""
+		set expect "$msg\n    while executing\n\"$cinfo\"$tail"
+		if {$errInfo eq $expect} {
+		    #
+		    # The stack has only the eval from the expanded command
+		    # Do not generate any stack trace here.
+		    #
+		    dict unset opts -errorinfo
+		    dict incr opts -level
+		    return -options $opts $msg
+		}
+		#
+		# Stack trace is nested, trim off just the contribution
+		# from the extra "eval" of $args due to the "catch" above.
+		#
+		set last [string last $tail $errInfo]
+		if {$last + [string length $tail] != [string length $errInfo]} {
+		    # Very likely cannot happen
+		    return -options $opts $msg
+		}
+		set errInfo [string range $errInfo 0 $last-1]
+		set tail "\"$cinfo\""
+		set last [string last $tail $errInfo]
+		if {$last < 0 || $last + [string length $tail] != [string length $errInfo]} {
+		    return -code error -errorcode $errCode \
+			    -errorinfo $errInfo $msg
+		}
+		set errInfo [string range $errInfo 0 $last-1]
+		set tail "\n    invoked from within\n"
+		set last [string last $tail $errInfo]
+		if {$last + [string length $tail] == [string length $errInfo]} {
+		    return -code error -errorcode $errCode \
+			    -errorinfo [string range $errInfo 0 $last-1] $msg
+		}
+		set tail "\n    while executing\n"
+		set last [string last $tail $errInfo]
+		if {$last + [string length $tail] == [string length $errInfo]} {
+		    return -code error -errorcode $errCode \
+			    -errorinfo [string range $errInfo 0 $last-1] $msg
+		}
+		return -options $opts $msg
+	    } else {
+		dict incr opts -level
+		return -options $opts $msg
+	    }
+	}
+    }
+    #set isrepl [expr {[file tail [file rootname [info script]]] eq "repl"}]
+    set isrepl $::repl::running ;#may not be reading though
+    if {$isrepl} {
+        #set ::tcl_interactive 1
+    }
+    if {$isrepl || (([info level] == 1) && (([info script] eq "" ) )
+	    && ([info exists tcl_interactive] && $tcl_interactive))} {
+	if {![info exists auto_noexec]} {
+	    set new [auto_execok $name]
+	    if {$new ne ""} {
+		set redir ""
+		if {[namespace which -command console] eq ""} {
+		    set redir ">&@stdout <@stdin"
+		}
+
+
+        #experiment todo - use twapi and named pipes
+        #twapi::namedpipe_server {\\.\pipe\something} 
+        #Then override tcl 'exec' and replace all stdout/stderr/stdin with our fake ones
+        #These can be stacked with shellfilter and operate as OS handles - which we can't do with fifo2 etc
+        #
+       
+
+        # 'script' command to fake a tty 
+        # note that we lose the exit code from the underlying command by using 'script' if we call shellfilter::run without -e option to script 
+        set scr [auto_execok script]
+        if {$scr ne ""} {
+            if {[string first " " $new] > 0} {
+                set c1 $name
+            } else {
+                set c1 $new
+            }
+            #set scriptrun "( $c1 [lrange $args 1 end] )"
+            
+            set scriptrun_commandlist [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $args]
+            
+            if 0 {
+            set scriptrun "( $c1 "
+            foreach a [lrange $args 1 end] {
+                if {[string first " " $a] > 0} {
+                    #append scriptrun "\"$a\""
+                    append scriptrun $a
+                } else {
+                    append scriptrun $a
+                }
+                append scriptrun " "
+            }
+            append scriptrun " )"
+            }
+            #-------------------------------------
+            if 0 {
+            package require string::token::shell
+            set shellparts [string token shell -indices $args]
+            
+            set scriptrun "( $c1 "
+            foreach info [lrange $shellparts 1 end] {
+                set type [lindex $info 0]
+                if {$type eq "D:QUOTED"} {
+                    append scriptrun "\""
+                    append scriptrun [lindex $info 3]
+                    append scriptrun "\""
+                } elseif {$type eq "S:QUOTED"} {
+                    append scriptrun "'"
+                    append scriptrun [lindex $info 3]
+                    append scriptrun "'"
+                } elseif {$type eq "PLAIN"} {
+                    append scriptrun [lindex $info 3]
+                } else {
+                    error "Can't interpret '$args' with sh-like syntax"
+                }
+                append scriptrun " "
+            }
+            append scriptrun " )"
+            }
+            
+            #-------------------------------------
+            #puts stderr ">>>scriptrun_commandlist: $scriptrun_commandlist"
+            
+            #uplevel 1 [list ::catch \
+                [list ::shellfilter::run [list $scr -q -e -c $scriptrun /dev/null] -teehandle punk -inbuffering line -outbuffering none ] \
+                ::tcl::UnknownResult ::tcl::UnknownOptions]
+            
+            uplevel 1 [list ::catch \
+                [list ::shellfilter::run $scriptrun_commandlist -teehandle punk -inbuffering line -outbuffering none ] \
+                ::tcl::UnknownResult ::tcl::UnknownOptions]
+            
+            
+            
+            #puts stderr "script result $::tcl::UnknownOptions $::tcl::UnknownResult"
+        } else {
+            uplevel 1 [list ::catch \
+                [list ::shellfilter::run [concat $new [lrange $args 1 end]] -teehandle punk -inbuffering line -outbuffering none ] \
+                ::tcl::UnknownResult ::tcl::UnknownOptions]
+        }
+        if {[string trim $::tcl::UnknownResult] ne "exitcode 0"} {
+            dict set ::tcl::UnknownOptions -code error 
+            set ::tcl::UnknownResult "Non-zero exit code from command '$c1 [lrange $args 1 end]' $::tcl::UnknownResult"
+        } else {
+            #no point returning "exitcode 0" if that's the only non-error return. 
+            #It is misleading. Better to return empty string.
+            set ::tcl::UnknownResult ""
+        }
+
+
+		#uplevel 1 [list ::catch \
+		#	[concat exec $redir $new [lrange $args 1 end]] \
+		#	::tcl::UnknownResult ::tcl::UnknownOptions]
+
+        #puts "===exec with redir:$redir $::tcl::UnknownResult =="
+		dict incr ::tcl::UnknownOptions -level
+		return -options $::tcl::UnknownOptions $::tcl::UnknownResult
+	    }
+	}
+	if {$name eq "!!"} {
+	    set newcmd [history event]
+	} elseif {[regexp {^!(.+)$} $name -> event]} {
+	    set newcmd [history event $event]
+	} elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $name -> old new]} {
+	    set newcmd [history event -1]
+	    catch {regsub -all -- $old $newcmd $new newcmd}
+	}
+	if {[info exists newcmd]} {
+	    tclLog $newcmd
+	    history change $newcmd 0
+	    uplevel 1 [list ::catch $newcmd \
+		    ::tcl::UnknownResult ::tcl::UnknownOptions]
+	    dict incr ::tcl::UnknownOptions -level
+	    return -options $::tcl::UnknownOptions $::tcl::UnknownResult
+	}
+
+	set ret [catch {set candidates [info commands $name*]} msg]
+	if {$name eq "::"} {
+	    set name ""
+	}
+	if {$ret != 0} {
+	    dict append opts -errorinfo \
+		    "\n    (expanding command prefix \"$name\" in unknown)"
+	    return -options $opts $msg
+	}
+	# Filter out bogus matches when $name contained
+	# a glob-special char [Bug 946952]
+	if {$name eq ""} {
+	    # Handle empty $name separately due to strangeness
+	    # in [string first] (See RFE 1243354)
+	    set cmds $candidates
+	} else {
+	    set cmds [list]
+	    foreach x $candidates {
+		if {[string first $name $x] == 0} {
+		    lappend cmds $x
+		}
+	    }
+	}
+	if {[llength $cmds] == 1} {
+	    uplevel 1 [list ::catch [lreplace $args 0 0 [lindex $cmds 0]] \
+		    ::tcl::UnknownResult ::tcl::UnknownOptions]
+	    dict incr ::tcl::UnknownOptions -level
+	    return -options $::tcl::UnknownOptions $::tcl::UnknownResult
+	}
+	if {[llength $cmds]} {
+	    return -code error "ambiguous command name \"$name\": [lsort $cmds]"
+	}
+    }
+    return -code error -errorcode [list TCL LOOKUP COMMAND $name] \
+	"invalid command name \"$name\""
+}
+
+
+proc know {cond body} {
+    proc unknown {args} [string map [list @c@ $cond @b@ $body] {
+        if {![catch {expr {@c@}} res] && $res} {
+            return [eval {@b@}]
+            #tailcall  @b@
+        }
+    }][info body unknown]
+}
+proc know? {} {
+    puts [string range [info body unknown] 0 511]
+}
+if 1 {
+know {[expr $args] || 1} {expr $args}
+know {[regexp {^([0-9]+)\.\.([0-9]+)$} [lindex $args 0] -> from to]} {
+   set res {}
+   while {$from<=$to} {lappend res $from; incr from}
+   set res
+}
+
+
+#run as raw string instead of tcl-list - no variable subst  etc
+proc do_runraw {commandline} {
+    #return [shellfilter::run [lrange $args 1 end] -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler]
+    puts stdout ">>runraw got: $commandline"
+    
+    #run always echoes anyway.. as we aren't diverting stdout/stderr off for capturing
+    #for consistency with other runxxx commands - we'll just consume it. (review)
+    #set wordparts [regexp -inline -all {\S+} $commandline]
+    package require string::token::shell
+    set parts [string token shell -indices $commandline]
+    puts stdout ">>shellparts: $parts"
+    
+    set runwords [list]
+    foreach p $parts {
+        set ptype [lindex $p 0]
+        set pval [lindex $p 3]
+        if {$ptype eq "PLAIN"} {
+            lappend runwords [lindex $p 3]
+        } elseif {$ptype eq "D:QUOTED"} {
+            set v {"}
+            append v $pval
+            append v {"}
+            lappend runwords $v
+        } elseif {$ptype eq "S:QUOTED"} {
+            set v {'}
+            append v $pval
+            append v {'}
+            lappend runwords $v
+        }
+    }
+    puts stdout ">>runraw runwords: $runwords"
+    set runwords [lrange $runwords 1 end]
+    
+    puts stdout ">>runraw runwords: $runwords"
+    #set args [lrange $args 1 end]
+    #set runwords [lrange $wordparts 1 end]
+    
+    set known_runopts [list "-echo" "-e" "-terminal" "-t"]
+    set aliases [list "-e" "-echo" "-echo" "-echo" "-t" "-terminal" "-terminal" "-terminal"] ;#include map to self
+    set runopts [list]
+    set cmdwords [list]
+    set idx_first_cmdarg [lsearch -not $runwords "-*"]
+    set runopts [lrange $runwords 0 $idx_first_cmdarg-1]
+    set cmdwords [lrange $runwords $idx_first_cmdarg end]
+    
+    foreach o $runopts {
+        if {$o ni $known_runopts} {
+            error "runout: Unknown runoption $o"
+        }
+    }
+    set runopts [lmap o $runopts {dict get $aliases $o}]
+    
+    set cmd_as_string [join $cmdwords " "]
+    puts stdout ">>cmd_as_string: $cmd_as_string"
+    
+    if {"-terminal" in $runopts} {
+        set tcmd [shellfilter::get_scriptrun_from_cmdlist_dquote_if_not $cmdwords]
+        puts stdout ">>tcmd: $tcmd"
+        #set exitinfo [shellfilter::run $tcmd -teehandle punk -inbuffering line -outbuffering none ]
+        set exitinfo "not-implemented"
+    } else {
+        set exitinfo [shellfilter::run $cmdwords -teehandle punk -inbuffering line -outbuffering none ]
+    }
+    
+    if {[dict exists $exitinfo error]} {
+        #todo - check errorInfo makes sense.. return -code? tailcall?
+        error [dict get $exitinfo error]
+    }
+    return $exitinfo
+}
+
+#NOTE: the run,runout,runerr,runx commands only produce an error if the command didn't run.
+# - If it did run, but there was a non-zero exitcode it is up to the application to check that.
+#This is deliberate, but means 'catch' doesn't catch errors within the command itself -  the exitcode has to be checked.
+#The user can always use exec for different process error semantics (they don't get exitcode with exec)
+know {[lindex $args 0] eq "runraw"} {
+    return [do_run $args]
+}
+know {[lindex $args 0] eq "run"} {
+    set args [lrange $args 1 end]
+    set known_runopts [list "-echo" "-e"]
+    set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self
+    set runopts [list]
+    set cmdargs [list]
+    set idx_first_cmdarg [lsearch -not $args "-*"]
+    set runopts [lrange $args 0 $idx_first_cmdarg-1]
+    set cmdargs [lrange $args $idx_first_cmdarg end]
+    foreach o $runopts {
+        if {$o ni $known_runopts} {
+            error "run: Unknown runoption $o"
+        }
+    }
+    set runopts [lmap o $runopts {dict get $aliases $o}]
+   
+    set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ]
+}
+
+know {[lindex $args 0] eq "runout"} {
+    set ::runout ""
+
+    set args [lrange $args 1 end]
+    set known_runopts [list "-echo" "-e"]
+    set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self
+    set runopts [list]
+    set cmdargs [list]
+    set idx_first_cmdarg [lsearch -not $args "-*"]
+    set runopts [lrange $args 0 $idx_first_cmdarg-1]
+    set cmdargs [lrange $args $idx_first_cmdarg end]
+    foreach o $runopts {
+        if {$o ni $known_runopts} {
+            error "runout: Unknown runoption $o"
+        }
+    }
+    set runopts [lmap o $runopts {dict get $aliases $o}]
+   
+    #puts stdout "RUNOUT cmdargs: $cmdargs"
+    
+    #set outvar_stackid [shellfilter::stack::add commandout tee_to_var  -action float -settings {-varname ::runout}]
+    if {"-echo" in $runopts} {
+        set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action sink-locked -settings {-varname ::runout}]
+    } else {
+        set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::runout}]
+    }
+
+    #shellfilter::run [lrange $args 1 end] -teehandle punk -outchan stdout -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler
+    set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none ]
+
+    shellfilter::stack::remove stdout $stdout_stackid
+    #shellfilter::stack::remove commandout $outvar_stackid
+    if {[dict exists $exitinfo error]} {
+        #we must raise an error. 
+        #todo - check errorInfo makes sense.. return -code? tailcall?
+        error [dict get $exitinfo error]
+    }
+    puts stderr $exitinfo
+    return $::runout
+}
+know {[lindex $args 0] eq "runerr"} {
+    set ::runerr ""
+
+    set args [lrange $args 1 end]
+    set known_runopts [list "-echo" "-e"]
+    set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self
+    set runopts [list]
+    set cmdargs [list]
+    set idx_first_cmdarg [lsearch -not $args "-*"]
+    set runopts [lrange $args 0 $idx_first_cmdarg-1]
+    set cmdargs [lrange $args $idx_first_cmdarg end]
+    foreach o $runopts {
+        if {$o ni $known_runopts} {
+            error "runout: Unknown runoption $o"
+        }
+    }
+    set runopts [lmap o $runopts {dict get $aliases $o}]
+
+    if {"-echo" in $runopts} {
+        set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::runerr}]
+    } else {
+        set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::runerr}]
+    }
+    set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler]
+    shellfilter::stack::remove stderr $stderr_stackid
+
+
+    #we raise an error because an error during calling is different to collecting stderr from a command, and the caller should be able to wrap in a catch
+    # to determine something other than just a nonzero exit code or output  on stderr.
+    if {[dict exists $exitinfo error]} {
+        #todo - check errorInfo makes sense.. return -code? tailcall?
+        error [dict get $exitinfo error]
+    }
+
+
+    puts stderr \n$exitinfo
+    return $::runerr
+}
+know {[lindex $args 0] eq "runx"} {
+    set ::runerr ""
+    set ::runout ""
+
+    set args [lrange $args 1 end]
+    set known_runopts [list "-echo" "-e"]
+    set aliases [list "-e" "-echo" "-echo" "-echo"] ;#include map to self
+    set runopts [list]
+    set cmdargs [list]
+    set idx_first_cmdarg [lsearch -not $args "-*"]
+    set runopts [lrange $args 0 $idx_first_cmdarg-1]
+    set cmdargs [lrange $args $idx_first_cmdarg end]
+    foreach o $runopts {
+        if {$o ni $known_runopts} {
+            error "runout: Unknown runoption $o"
+        }
+    }
+    set runopts [lmap o $runopts {dict get $aliases $o}]
+
+
+
+    #shellfilter::stack::remove stdout $::repl::id_outstack
+
+    if {"-echo" in $runopts} {
+        set stderr_stackid [shellfilter::stack::add stderr tee_to_var -action sink-locked -settings {-varname ::runerr}]
+        set stdout_stackid [shellfilter::stack::add stdout tee_to_var -action sink-locked -settings {-varname ::runout}]
+    } else {
+        set stderr_stackid [shellfilter::stack::add stderr var -action sink-locked -settings {-varname ::runerr}]
+        set stdout_stackid [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::runout}]
+    }
+    
+    set exitinfo [shellfilter::run $cmdargs -teehandle punk -inbuffering none -outbuffering none -stdinhandler ::repl::repl_handler]
+
+    shellfilter::stack::remove stdout $stdout_stackid
+    shellfilter::stack::remove stderr $stderr_stackid
+
+    set ::repl::output ""
+
+    
+    #set x [shellfilter::stack::add stdout var -action sink-locked -settings {-varname ::repl::runxoutput}]
+    set pretty ""
+    append pretty "stdout\n"
+    if {[string length $::runout]} {
+        append pretty "$::runout\n"
+    }
+    append pretty "stderr\n"
+    if {[string length $::runerr]} {
+        append pretty "$::runerr\n"
+    }
+    append pretty "$exitinfo"
+    #set ::repl::result_print 0
+    #return [lindex [list [list stdout $::runout stderr $::runerr {*}$exitinfo] [shellfilter::stack::remove stdout $x][puts -nonewline stdout $pretty][set ::repl::output ""]] 0]
+    
+    set ::repl::result_pretty $pretty
+    
+    if {[dict exists $exitinfo error]} {
+        #todo - check errorInfo makes sense.. return -code? tailcall?
+        error [dict get $exitinfo error]
+    }
+
+    
+    return [list stdout $::runout stderr $::runerr {*}$exitinfo]
+
+
+    #return [string map [list %o% [list $::runout] %e% [list $::runerr] %x% $exitinfo] {stdout\
+    #    %o%\
+    #    stderr\
+    #    %e%\
+    #    %x%\
+    #}]
+}
+}
+namespace eval repl {
+    variable output ""
+    #important not to initialize - as it can be preset by cooperating package before app-punk has been package required
+    variable post_script
+}
+
+
+proc repl::doprompt {prompt} {
+    #prompt to stderr. 
+    #We can pipe commands into repl's stdin without the prompt interfering with the output.
+    #Although all command output for each line goes to stdout - not just what is emmited with puts
+    if {$::tcl_interactive} {
+        puts -nonewline stderr $prompt
+        flush stderr
+    }
+}
+
+proc repl::start {inchan} {
+    variable command
+    variable running
+    variable reading
+    variable done
+    set running 1
+    set command ""
+    doprompt "P% "
+    fileevent $inchan readable [list [namespace current]::repl_handler $inchan]
+    set reading 1
+    vwait [namespace current]::done
+    #todo - override exit?
+    after 0 ::repl::post_operations
+    vwait repl::post_operations_done
+    return 0
+}
+proc repl::post_operations {} {
+    if {[info exists ::repl::post_script] && [string length $::repl::post_script]} {
+       #put aside post_script so the script has the option to add another post_script and restart the repl
+       set ::repl::running_script $::repl::post_script
+       set ::repl::post_script ""
+       uplevel #0 {eval $::repl::running_script}
+    }
+    
+    #todo - tidyup so repl could be restarted
+    
+    
+    set repl::post_operations_done 0
+}
+
+
+proc repl::reopen_stdin {} {
+    if {$::tcl_platform(platform) eq "windows"} {
+        puts stderr "|repl> Attempting reconnection of console to stdin by opening 'CON'"
+    } else {
+        puts stderr "|repl> Attempting reconnection of console to stdin by opening '/dev/tty'"
+    }
+    #puts stderr "channels:[chan names]"
+    #flush stderr
+    chan close stdin
+    if {$::tcl_platform(platform) eq "windows"} {
+        set s [open "CON" r]
+    } else {
+        #/dev/tty - reference to the controlling terminal for a process 
+        #review/test
+        set s [open "/dev/tty" r]
+    }
+
+    repl::start stdin
+}
+proc quit {} {
+    set ::repl::done "quit"
+}
+#just a failed experiment.. tried various things
+proc repl::reopen_stdinX {} {
+    #windows  - todo unix
+    package require twapi
+    
+    if 0 {
+    if {[catch {package require Memchan} errM]} {
+        #package require tcl::chan::fifo2
+        #lassign [tcl::chan::fifo2] a b
+        package require tcl::chan::fifo
+        set x [tcl::chan::fifo]
+    } else {
+        #lassign [fifo2] a b
+        set x [fifo] 
+    }
+    #first channel opened after stdin closed becomes stdin
+    #use a fifo or fifo2 because [chan pipe] assigns the wrong end first!
+    #a will be stdin 
+    }
+    #these can't replace proper stdin (filehandle 0) because they're not 'file backed' or 'os level'
+    #try opening a named pipe server to become stdin
+    set pipename {\\.\pipe\stdin_%id%}
+    set pipename [string map [list %id% [pid]] $pipename]
+    
+    
+    
+    package require tcl::chan::fifo
+    
+    chan close stdin
+    lassign [tcl::chan::fifo] a 
+    
+    
+    puts stderr "newchan: $a"
+    puts stderr "|test> $a [chan conf $a]"
+    
+    #set server [twapi::namedpipe_server $pipename]
+    #set client [twapi::namedpipe_client $pipename] ;#open a client and connect to the server we just made
+
+    puts stderr "chan names: [chan names]"
+    
+    #by now $server not valid?
+    #set server stdin 
+    
+    #chan configure $server -buffering line -encoding unicode
+    #chan configure $client -buffering line -encoding unicode
+    
+    #puts stderr "|test>ns-server $server [chan conf $server]"
+    #puts stderr "|test>ns-client $client [chan conf $client]"
+    
+    set conin [twapi::get_console_handle stdin]
+    twapi::set_standard_handle stdin $conin
+    
+    set h_in [twapi::get_standard_handle stdin]
+    
+    puts stderr "|test> $a [chan conf $a]"
+    
+    #chan configure $client -blocking 0
+    after 10 repl::start $a
+    
+}
+proc repl::repl_handler {chan} {
+    variable command
+    variable running 
+    variable reading
+    variable post_script
+    variable id_outstack
+    variable result_print
+    variable result_pretty
+    set chunksize [gets $chan line]
+    if {$chunksize < 0} {
+        if {[chan eof $chan]} {
+            fileevent $chan readable {}
+            set reading 0 
+            set running 0
+            if {$::tcl_interactive} {
+                puts stderr "\n|repl> EOF on $chan."
+            }
+            set [namespace current]::done 1
+            #test
+            repl::reopen_stdin
+            return
+        }
+    }
+    append command $line
+    if {[info complete $command]} {
+        set ::repl::output ""
+        set id_outstack [shellfilter::stack::add stdout tee_to_var -settings {-varname ::repl::output}]
+        #chan configure stdout -buffering none
+        fileevent $chan readable {}
+        set reading 0
+        set result_print 1 
+        set result_pretty "" 
+        #don't let unknown use 'args' to convert command to list
+
+        if {[string equal -length [string length "runraw "] "runraw " $command]} {
+            set status [catch {uplevel #0 [list do_runraw $command]} result]
+        } else {
+            set status [catch {uplevel #0 $command} result]
+        }
+        set lastoutchar [string range $::repl::output end-1 end]
+        #puts stderr "<output>'$::repl::output' lastoutchar:'$lastoutchar' result:'$result'"
+        shellfilter::stack::remove stdout $id_outstack
+        if {!$result_print} {
+            set result ""
+            set lastoutchar ""
+        }
+        #$command is an unevaluated script at this point 
+        # so may not be a well formed list e.g 'set x [list a "b"]' 
+        #- lindex will fail
+        #if {[lindex $command 0] eq "runx"} {}
+        
+        set test [string trim $command]
+        if {[string equal -length [string length "runx "] "runx " $command]} {
+            if {[string length $result_pretty]} {
+                set result $result_pretty 
+            }
+        }
+        fileevent $chan readable [list [namespace current]::repl_handler $chan]
+        set reading 1
+        if {$result ne ""} {
+            if {$status == 0} {
+                if {[string length $lastoutchar]} {
+                    puts \n$result
+                } else {
+                    puts $result
+                }
+                doprompt "P% "
+            } else {
+                puts stderr $result
+                doprompt "p% "
+            }
+        } else {
+            if {[string length $lastoutchar]} {
+                doprompt "\nP% "
+            } else {
+                doprompt "P% "
+            }
+        }
+        set command ""
+    } else {
+        append command \n
+        doprompt "> "
+    }
+}
+repl::start stdin
+
+exit 0
+
+#repl::start $program_read_stdin_pipe
+

src/punk86.vfs/lib/app-shellspy/pkgIndex.tcl

@@ -0,0 +1,3 @@
+
+  package ifneeded app-shellspy 1.0 [list source [file join $dir shellspy.tcl]]
+

src/punk86.vfs/lib/app-shellspy/shellspy.tcl

@@ -0,0 +1,717 @@
+#! /usr/bin/env tclsh
+#
+#copyright 2023 Julian Marcel Noble
+#license: BSD (revised 3-clause)
+#
+#see notes at beginning of shellspy namespace re stdout/stderr
+#
+#SHELLSPY - provides commandline flag information and stdout/stderr logging/mirroring without output/pipeline interference,
+# or modified output if modifying filters explicitly configured.
+#
+#shellspy uses the shellfilter and flagfilter libraries to run a commandline with tee-diversions of stdout/stderr to configured syslog/file logs
+#Because it is a tee, the command's stdout/stderr are still available as direct output from this script.
+#Various filters/modifiers/redirections can be placed on the channel stacks for stdin/stderr using the shellfilter::stack api 
+# and other shellfilter:: helpers such as shellfilter::redir_output_to_log
+# Redirecting stderr/stdout in this way prior to the actual command run will not interfere with the command/pipeline output due to the way
+# shellfilter temporarily inserts it's own tee into the stack at the point of the highest existing redirection it encounters. 
+#
+#A note on input/output convention regarding channels/pipes
+# we write to an output, read from an input.
+# e.g when creating a pipe with 'lassign [chan pipe] in out' we write to out and read from in.
+# This is potentially confusing from an OO-like perspective thinking of a pipe object as a sort of object.
+# Don't think of it from the perspective of the pipe - but from the program using it.
+# This is not a convention invented here for shellspy - but it seems to match documentation and common use e.g for 'chan pending input|output chanid'
+# This matches the way we write to stdout read from stdin. 
+# Possibly using read/write related naming for pipe ends is clearer. eg 'lassign [chan pipe] rd_pipe1 wr_pipe1'
+#
+package provide app-shellspy 1.0
+
+
+#a test for windows
+#fconfigure stdin -encoding utf-16le
+#fconfigure stdout -encoding utf-16le
+
+#tcl::tm::remove {*}[tcl::tm::list]
+
+#add dir outside of tclkit/exe so we can override with higher versions if necessary without rebuilding 
+set m_dir [file normalize [file join [file dirname [info nameofexecutable]] modules]]
+tcl::tm::add $m_dir
+set m_dir [file normalize [file join [file dirname [info script]] ../../../modules]]
+tcl::tm::add $m_dir
+
+
+#experiment - todo make a flag for it if it's useful
+#Middle cap for direct dispatch without flagcheck arg processing or redirections or REPL.
+set arg1 [lindex $::argv 0]
+if {[file extension $arg1] in [list .tCl]} {
+    set ::argv [lrange $::argv 1 end]
+    set ::argc [llength $::argv]
+    set scriptfile [file normalize $arg1]
+    if {![file exists $scriptfile]} {
+        #try the lowercase version (extension lowercased only) so that file doesn't have to be renamed to use alternate dispatch
+        set scriptfile [file rootname $scriptfile][string tolower [file extension $scriptfile]]
+    }
+    source [file normalize $arg1]
+
+    #package require app-punk
+
+} else {
+
+
+
+#set m_dir [file join $starkit::topdir modules]
+
+#lappend auto_path c:/tcl/lib/tcllib1.20
+package require flagfilter
+package require shellfilter
+package require Thread
+
+#package require packageTrace
+
+set ::testconfig 5
+
+namespace eval shellspy {
+    variable shellspy_status_log "shellspy-[clock micros]"
+    #shellfilter::log::open $shellspy_status_log [list -tag $shellspy_status_log -syslog 172.16.6.42:51500 -file ""]
+    shellfilter::log::open $shellspy_status_log [list -tag $shellspy_status_log -syslog 127.0.0.1:514 -file ""]
+    shellfilter::log::write $shellspy_status_log "shellspy launch with args '$::argv'"
+    shellfilter::log::write $shellspy_status_log "stdout/stderr encoding: [chan configure stdout -encoding]/[chan configure stderr -encoding]"
+
+    #-------------------------------------------------------------------------
+    ##don't write to stdout/stderr before you've redirected them to a log using shellfilter functions
+    ## puts to stdout/stderr will comingle with command's output if performed before the channel stacks are configured.
+    
+    chan configure stdin -buffering line 
+    chan configure stdout -buffering none 
+    chan configure stderr -buffering none 
+
+    #set id_ansistrip [shellfilter::stack::add stderr ansistrip    -settings {}]
+    #set id_ansistrip [shellfilter::stack::add stdout ansistrip    -settings {}]
+
+    lassign [shellfilter::redir_output_to_log "SPY"] id_stdout_redir id_stderr_redir
+    
+    
+    ###
+    #we can now safely write to stderr/stdout and it will not interfere with stderr/stdout from the dispatched command.
+    #This is because when shellfilter::run is called it temporarily adds it's own filter in place of the redirection we just added.
+    # shellfilter::run installs tee_to_pipe on stdout & stderr with -action sink-aside.
+    # sink-aside means to sink down the filter stack to the topmost filter that is diversionary, and replace it.
+    # when the command finishes running, the redirecting filter that it displaced is reinstalled in the stack.
+    ###
+
+    ###
+    #Note that futher filters installed here will sit 'above' any of the redirecting filters
+    # so apply to both the shellfilter::run commandline,
+    # as well as writes to stderr/stdout from here or other libraries operating in this process.
+    # To bypass the the filter-stack and still emit to syslog etc -
+    # you can use shellfilter::log::open and shellfilter::log::write  e.g
+    #   shellfilter::log::open  "mystatuslog" [list -tag "mystatuslog" -syslog 172.16.6.42:51500 -file ""]
+    #   shellfilter::log::write "mystatuslog" "shellspy launch"
+    #
+    ####
+    #set id_ansistrip [shellfilter::stack::add stderr ansistrip -action float  -settings {}]
+    #set id_ansistrip [shellfilter::stack::add stdout ansistrip -action float  -settings {}]
+
+
+    ##stdin stack operates in reverse compared to stdout/stderr in that first added to stack is first to see the data
+    ##for stdin: first added to stack is 'upstream' as it will always encounter the data before later ones added to the stack. 
+    ##for stdout: first added to stack is 'downstream' as it will alays encounter the data after others on the stack
+    #shellfilter::stack::add stdin ansistrip -action {}  -settings {}
+    #shellfilter::stack::add stdin tee_to_log  -settings {-tag "input" -raw 1 -syslog 172.16.6.42:51500 -file ""}
+
+    #-------------------------------------------------------------------------
+    ##note - to use shellfilter::stack::new - the fifo2 end at the local side requires the event loop to be running
+    ## for interactive testing a relatively simple repl.tcl can be used.
+
+    #todo - default to no logging.. add special flag in checkflags to indicate end of options for matched command only e.g --- ? 
+    # then prioritize these results from checkflags to configure pre-dispatch behaviour by running a predispatch script(?)
+    #
+    # we can log flag-processing info coming from checkflags.. but we don't want to do two opt scans and emit it twice.
+    # configuration of the logging for flag/opt parsing should come from a config file and default to none.
+    set stdout_log [file normalize ~]/shellspy-stdout.txt
+    set stderr_log [file normalize ~]/shellspy-stderr.txt
+
+    set outdeviceinfo [shellfilter::stack::new shellspyout -settings [list -tag "shellspyout" -buffering none -raw 1 -syslog 127.0.0.1:514 -file $stdout_log]]
+    set commandlog [dict get $outdeviceinfo localchan]
+    #puts $commandlog "HELLO $commandlog"
+    #flush $commandlog
+    set errdeviceinfo [shellfilter::stack::new shellspyerr -settings [list -tag "shellspyerr" -buffering none -raw 1 -syslog 127.0.0.1:514 -file $stderr_log]]
+
+    #note that this filter is inline with the data teed off to the shellspyout log. 
+    #To filter the main stdout an addition to the stdout stack can be made. specify -action float to have it affect both stdout and the tee'd off data.
+    set id_ansistrip [shellfilter::stack::add shellspyout ansistrip    -settings {}]
+
+
+    #set id_out [shellfilter::stack::add stdout rebuffer -settings {}]
+
+    #an example filter to capture some output to a var for later use - this one is for ansible-playbook
+    #set ::recap ""
+    #set id_tee_grep [shellfilter::stack::add shellspyout tee_grep_to_var -settings {-grep ".*PLAY RECAP.*|.*fatal:.*|.*changed:.*" -varname ::recap -pre 1 -post 3}]
+
+    namespace import ::flagfilter::check_flags
+
+    namespace eval shellspy::callbacks {}
+    namespace eval shellspy::parameters {}
+
+
+    proc do_callback {func args} {
+        variable shellspy_status_log
+        set exedir [file dirname [info nameofexecutable]]
+        set dispatchtcl [file join $exedir callbacks dispatch.tcl]
+        if {[file exists $dispatchtcl]} {
+          source $dispatchtcl
+          if {[llength [info commands shellspy::callbacks::$func]]} {
+            shellfilter::log::write $shellspy_status_log "found shellspy::callbacks::$func - calling" 
+            if {[catch {
+                  set args [shellspy::callbacks::$func {*}$args]
+                } errmsg]} {
+                shellfilter::log::write $shellspy_status_log "ERROR in shellspy::callbacks::$func\n errormsg:$errmsg" 
+                error $errmsg
+            }
+          }
+        }
+        return $args
+    }
+    proc do_callback_parameters {func args} {
+        variable shellspy_status_log
+        set exedir [file dirname [info nameofexecutable]]
+        set paramtcl [file join $exedir callbacks parameters.tcl]
+        set params $args
+        if {[file exists $paramtcl]} {
+          source $paramtcl
+          if {[llength [info commands shellspy::parameters::$func]]} {
+            shellfilter::log::write $shellspy_status_log "found shellspy::parameters::$func - calling" 
+            if {[catch {
+                  set params [shellspy::parameters::$func $params]
+                } errmsg]} {
+                shellfilter::log::write $shellspy_status_log "ERROR in shellspy::parameters::$func\n errormsg:$errmsg" 
+            }
+          }
+        }
+        return $params
+    }
+
+    #some tested configs
+    proc get_channel_config {config} {
+        #note tcl script being called from wrong place.. configs don't affect: todo - move it.
+        set params [dict create]
+        if {$config == 0} {
+            #bad for: everything. extra cr
+            dict set params -inbuffering line    
+            dict set params -outbuffering line   
+            dict set params -readprocesstranslation auto ;#default
+            dict set params -outtranslation auto  
+        }
+
+        if {$config == 1} {
+            #ok for: cmd, cmd/u/c,raw,pwsh, sh,raw, tcl script process
+            #not ok for: bash,wsl, tcl script
+            dict set params -inbuffering line    
+            dict set params -outbuffering line  
+            dict set params -readprocesstranslation auto ;#default
+            dict set params -outtranslation lf
+        }
+         if {$config == 2} {
+            #ok for: cmd, cmd/uc,pwsh,sh  , tcl script process
+            #not ok for: tcl script, bash, wsl
+            dict set params -inbuffering none             ;#default
+            dict set params -outbuffering none            ;#default
+            dict set params -readprocesstranslation auto  ;#default 
+            dict set params -outtranslation lf            ;#default
+        }
+        if {$config == 3} {
+            #ok for: cmd
+            dict set params -inbuffering line
+            dict set params -outbuffering line
+            dict set params -readprocesstranslation lf
+            dict set params -outtranslation lf
+        }
+        if {$config == 4} {
+            #ok for: cmd,cmd/uc,raw,sh
+            #not ok for pwsh,bash,wsl, tcl script, tcl script process
+            dict set params -inbuffering none
+            dict set params -outbuffering none
+            dict set params -readprocesstranslation lf
+            dict set params -outtranslation lf
+        }
+        
+        if {$config == 5} {
+            #ok for: pwsh,cmd,cmd/u/c,raw,sh, tcl script process
+            #not ok for bash,wsl
+            #ok for vim cmd/u/c but only with to_unix filter on stdout (works in gvim and console)
+            dict set params -inbuffering none
+            dict set params -outbuffering none
+            dict set params -readprocesstranslation crlf
+            dict set params -outtranslation lf
+        }
+        if {$config == 6} {
+            #ok for: cmd,cmd/u/c,pwsh,raw,sh,bash
+            #not ok for: vim with cmd /u/c (?)
+            dict set params -inbuffering line
+            dict set params -outbuffering line
+            dict set params -readprocesstranslation crlf
+            dict set params -outtranslation lf
+        }
+        if {$config == 7} {
+            #ok for: sh,bash
+            #not ok for: wsl (display ok but extra cr), cmd,cmd/u/c,pwsh, tcl script, tcl script process, raw
+            dict set params -inbuffering none
+            dict set params -outbuffering none
+            dict set params -readprocesstranslation crlf
+            dict set params -outtranslation crlf
+        }
+        if {$config == 8} {
+            #not ok for anything..all have extra cr
+            dict set params -inbuffering none
+            dict set params -outbuffering none
+            dict set params -readprocesstranslation lf
+            dict set params -outtranslation crlf
+        }
+        return $params
+    }
+
+
+   
+    
+    proc do_in_powershell {args} {
+        variable shellspy_status_log
+        shellfilter::log::write $shellspy_status_log "do_in_powershell got '$args'"
+        set args [do_callback powershell {*}$args]
+        set params [do_callback_parameters powershell]
+        dict set params -teehandle shellspy
+        
+
+        #readprocesstranslation  lf - doesn't work for buffering line or none
+        #readprocesstranslation crlf works for buffering line and none with outchantranslation lf
+        
+        set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered
+
+        
+
+        #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] -debug 1]
+
+
+        set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c {*}$args] {*}$params]
+        #Passing args in as a single element will tend to make powershell treat the args as a 'script block'
+        # (powershell sees items in curly brackets {} as a scriptblock  - when called from non-powershell, this tends to just echo back the contents)
+        #set exitinfo [shellfilter::run [list pwsh -nologo -noprofile -c $args] {*}$params]
+        if {[lindex $exitinfo 0] eq "exitcode"} {
+            shellfilter::log::write $shellspy_status_log "do_in_powershell returning $exitinfo"
+            #exit [lindex $exitinfo 1]
+        }
+    }
+    proc do_in_powershell_terminal {args} {
+        variable shellspy_status_log
+        shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal got '$args'"
+        dict set params -teehandle shellspy
+        set params [dict merge $params [get_channel_config $::testconfig]] ;#working: 5 unbuffered, 6 linebuffered
+        
+        set cmdlist [list pwsh -nologo -noprofile -c {*}$args]
+        set cmdlist [shellfilter::get_scriptrun $cmdlist]
+        shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal as script: '$cmdlist'"
+        
+        set exitinfo [shellfilter::run $cmdlist {*}$params]
+        if {[lindex $exitinfo 0] eq "exitcode"} {
+            shellfilter::log::write $shellspy_status_log "do_in_powershell_terminal returning $exitinfo"
+        }
+    }
+
+
+    proc do_in_cmdshell {args} {
+        variable shellspy_status_log
+        shellfilter::log::write $shellspy_status_log "do_in_cmdshell got '$args'"
+        set args [do_callback cmdshell {*}$args]
+        set params [do_callback_parameters cmdshell]
+        
+
+        dict set params -teehandle shellspy
+        dict set params -copytempfile 1
+
+        set params [dict merge $params [get_channel_config $::testconfig]]
+        
+        #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}]       
+
+        #set exitinfo [shellfilter::run "cmd /c $args" -debug 1]
+        set exitinfo [shellfilter::run [list cmd /c {*}$args] {*}$params]
+        #set exitinfo [shellfilter::run [list cmd /c {*}$args] -debug 1]
+        
+        #shellfilter::stack::remove stdout $id_out
+        
+        
+        
+        if {[lindex $exitinfo 0] eq "exitcode"} {
+            #exit [lindex $exitinfo 1]
+            shellfilter::log::write $shellspy_status_log "do_in_cmdshell returning $exitinfo"
+            #puts stderr "do_in_cmdshell returning $exitinfo"
+        }
+    }
+    proc do_in_cmdshellb {args} {
+    
+        variable shellspy_status_log
+        shellfilter::log::write $shellspy_status_log "do_in_cmdshellb got '$args'"
+        
+        set args [do_callback cmdshellb {*}$args]
+        
+        
+        shellfilter::log::write $shellspy_status_log "do_in_cmdshellb post_callback args '$args'"
+        
+        set params [do_callback_parameters cmdshellb]
+        dict set params -teehandle shellspy
+        dict set params -copytempfile 1
+        dict set params -debug 0
+        
+        #-----------------------------
+        #channel config 6 and towindows sink-aside-locked {-junction 1} works with vim-flog
+        #-----------------------------
+        set params [dict merge $params [get_channel_config 6]]
+        #set id_out [shellfilter::stack::add stdout tounix -action sink-aside-locked -settings {-junction 1}]       
+
+
+        set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params]
+
+        #shellfilter::stack::remove stdout $id_out
+
+        if {[lindex $exitinfo 0] eq "exitcode"} {
+            shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning with exitcode $exitinfo"
+        } else {
+            shellfilter::log::write $shellspy_status_log "do_in_cmdshellb returning WITHOUT exitcode $exitinfo"
+        }
+    }
+    proc do_in_cmdshelluc {args} {
+        variable shellspy_status_log
+        shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc got '$args'"
+        set args [do_callback cmdshelluc {*}$args]
+        set params [do_callback_parameters cmdshell]
+        #set exitinfo [shellfilter::run "cmd /c $args" -debug 1]
+        dict set params -teehandle shellspy
+        dict set params -copytempfile 1
+        dict set params -debug 0
+        
+        #set params [dict merge $params [get_channel_config $::testconfig]]
+
+        set params [dict merge $params [get_channel_config 1]]
+        #set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}]
+        
+        set id_out [shellfilter::stack::add stdout tounix -action sink-locked -settings {}]
+        
+        set exitinfo [shellfilter::run [list cmd /u/c {*}$args] {*}$params]
+        shellfilter::stack::remove stdout $id_out
+        #chan configure stdout -translation crlf
+
+        if {[lindex $exitinfo 0] eq "exitcode"} {
+            #exit [lindex $exitinfo 1]
+            shellfilter::log::write $shellspy_status_log "do_in_cmdshelluc returning $exitinfo"
+            #puts stderr "do_in_cmdshell returning $exitinfo"
+        }
+    }
+    proc do_raw {args} {
+        variable shellspy_status_log
+        shellfilter::log::write $shellspy_status_log "do_raw got '$args'"
+        set args [do_callback raw {*}$args]
+        set params [do_callback_parameters raw]
+        #set params {}
+        dict set params  -debug 0
+        #dict set params -outprefix "_test_"
+        dict set params -teehandle shellspy
+
+        
+        set params [dict merge $params [get_channel_config $::testconfig]]
+ 
+        
+        if {[llength $params]} {
+            set exitinfo [shellfilter::run $args {*}$params]
+        } else {
+            set exitinfo [shellfilter::run $args -debug 1 -outprefix "j"]
+        }
+        if {[lindex $exitinfo 0] eq "exitcode"} {
+            shellfilter::log::write $shellspy_status_log "do_raw returning $exitinfo"
+        }
+    }
+  
+    proc do_script_process {scriptname args} {
+        variable shellspy_status_log
+        shellfilter::log::write $shellspy_status_log "do_script_process got scriptname:'$scriptname' args:'$args'"
+        set args [do_callback script_process {*}$args]
+        set params [do_callback_parameters script_process]
+        dict set params -teehandle shellspy
+
+        set params [dict merge $params [get_channel_config $::testconfig]]
+
+        #todo - use glob to check capitalisation of file tail (.TCL vs .tcl .Tcl etc)
+        set exitinfo [shellfilter::run [concat [auto_execok tclsh] $scriptname $args] {*}$params]
+        if {[lindex $exitinfo 0] eq "exitcode"} {
+            shellfilter::log::write $shellspy_status_log "do_script_process returning $exitinfo"
+        }
+    }
+    proc do_script {scriptname replwhen args} {
+        #ideally we don't want to launch an external process to run the script
+        variable shellspy_status_log
+        shellfilter::log::write $shellspy_status_log "do_script got scriptname:'$scriptname' replwhen:$replwhen args:'$args'"
+        
+        set script [string map [list %a% $args %s% $scriptname] {
+set scriptname %s%
+set ::argv [list %a%]
+set ::argc [llength $::argv]
+source [file normalize $scriptname]
+    
+        }]
+
+        set repl_line "package require app-punk\n"
+
+        if {$replwhen eq "repl_first"} {
+            #we need to cooperate with the repl to get the script to run on exit
+            namespace eval ::repl {}
+            set ::repl::post_script $script
+            set script "$repl_line"
+        } elseif {$replwhen eq "repl_last"} {
+            append script $repl_line
+        } else {
+            #just the script
+        }
+
+
+        set args [do_callback script {*}$args]
+        set params [do_callback_parameters script]
+        dict set params -tclscript 1 ;#don't give callback a chance to omit/break this 
+        dict set params -teehandle shellspy
+        
+        set params [dict merge $params [get_channel_config $::testconfig]]
+
+        
+        set exitinfo [shellfilter::run $script {*}$params]
+        if {[lindex $exitinfo 0] eq "exitcode"} {
+          shellfilter::log::write $shellspy_status_log "do_script returning $exitinfo"
+        }
+    }
+
+    proc shellescape {arglist} {
+      set out [list]
+      foreach a $arglist {
+        set a [string map [list \\ \\\\ ] $a]
+        lappend out $a
+      }
+      return $out
+    } 
+    proc do_shell {shell args} {
+      variable shellspy_status_log
+      shellfilter::log::write $shellspy_status_log "do_shell $shell got '$args' [llength $args]"
+      set args [do_callback $shell {*}$args]
+      shellfilter::log::write $shellspy_status_log "do_shell $shell xgot '$args'"
+      set params [do_callback_parameters $shell]
+      dict set params -teehandle shellspy
+      
+      
+      set params [dict merge $params [get_channel_config $::testconfig]]
+        
+      set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -settings {-junction 1}]
+
+      #shells that take -c and need all args passed together as a string
+      
+      set exitinfo [shellfilter::run [concat $shell -c [shellescape $args]] {*}$params]
+
+      shellfilter::stack::remove stdout $id_out
+
+      
+      if {[lindex $exitinfo 0] eq "exitcode"} {
+        shellfilter::log::write $shellspy_status_log "do_shell $shell returning $exitinfo"
+      }
+    }
+    proc do_wsl {dist args} {
+      variable shellspy_status_log
+      shellfilter::log::write $shellspy_status_log "do_wsl $dist got '$args' [llength $args]"
+      set args [do_callback wsl {*}$args]  ;#use dist?
+      shellfilter::log::write $shellspy_status_log "do_wsl $dist xgot '$args'"
+      set params [do_callback_parameters wsl]
+      
+      dict set params -debug 0
+      
+      
+      set params [dict merge $params [get_channel_config $::testconfig]]
+      
+      
+      set id_out [shellfilter::stack::add stdout towindows -action sink-aside-locked -settings {-junction 1}]
+
+      
+      dict set params -teehandle shellspy  ;#shellspyout shellspyerr must exist
+      set exitinfo [shellfilter::run [concat wsl -d $dist -e [shellescape $args]] {*}$params]
+
+
+      shellfilter::stack::remove stdout $id_out
+
+
+      if {[lindex $exitinfo 0] eq "exitcode"} {
+        shellfilter::log::write $shellspy_status_log "do_wsl $dist returning $exitinfo"
+      }
+    }
+
+    #todo - load these from a callback
+    set commands [list]
+
+    #shout extension to force use of tclsh as a separate process 
+    #todo - detect various extensions - and use all script-preceding unmatched args as interpreter+options
+    #e.g perl,php,python etc.  
+    #For tcl will make it easy to test different interpreter output from tclkitsh, tclsh8.6, tclsh8.7 etc
+    #for now we have a hardcoded default interpreter for tcl as 'tclsh' - todo: get default interps from config 
+    #(or just attempt launch in case there is shebang line in script)
+    #we may get ambiguity with existing shell match-specs such as -c /c -r. todo - only match those in first slot?
+    lappend commands [list tclscriptprocess [list match [list .*\.TCL$ .*\.TM$ .*\.TK$] dispatch [list shellspy::do_script_process %matched%] dispatchtype tcl dispatchglobal 1 singleopts {any}]]
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list tclscriptprocess [list sub word$i  singleopts {any}]]
+    }
+
+    #camelcase convention .Tcl script before repl
+    lappend commands [list tclscriptbeforerepl [list match [list .*\.Tcl$ .*\.Tm$ .*\.Tk$ ] dispatch [list shellspy::do_script %matched% "repl_last"] dispatchtype tcl dispatchglobal 1 singleopts {any}]]
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list tclscriptbeforerepl [list sub word$i  singleopts {any}]]
+    }
+
+
+    #Backwards Camelcase convention  .tcL  - means repl first, script last
+    lappend commands [list tclscriptafterrepl [list match [list .*\.tcL$ .*\.tM$ .*\.tK$ ] dispatch [list shellspy::do_script %matched% "repl_first"] dispatchtype tcl dispatchglobal 1 singleopts {any}]]
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list tclscriptafterrepl [list sub word$i  singleopts {any}]]
+    }
+
+
+    #we've already handled .Tcl .tcL, .tCl, .TCL - handle any other capitalisations as a script in this process
+    lappend commands [list tclscript [list match [list .*\.tcl$ .*\.tCL$ .*\.TCl$  .*\.tm$ .*\.tk$ ] dispatch [list shellspy::do_script %matched% "no_repl"] dispatchtype tcl dispatchglobal 1 singleopts {any}]]
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list tclscript [list sub word$i  singleopts {any}]]
+    }
+
+
+
+    lappend commands  [list bashraw [list match ^bash$ dispatch [list shellspy::do_shell bash] dispatchtype raw dispatchglobal 1 singleopts {any}]]
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list bashraw [list sub word$i  singleopts {any}]]
+    }
+    lappend commands  {shraw {match ^sh$ dispatch {shellspy::do_shell sh} dispatchtype raw dispatchglobal 1 singleopts {any}}}
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list shraw [list sub word$i  singleopts {any}]]
+    }
+
+    lappend commands  [list runbash [list match ^b$ dispatch [list shellspy::do_shell bash] dispatchtype shell dispatchglobal 1 singleopts {any}]]
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list runbash [list sub word$i  singleopts {any}]]
+    }
+    lappend commands  {runsh {match ^s$ dispatch {shellspy::do_shell sh} dispatchtype shell dispatchglobal 1 singleopts {any}}}
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list runsh [list sub word$i  singleopts {any}]]
+    }
+
+    lappend commands  {runraw {match ^-r$ dispatch shellspy::do_raw dispatchtype raw dispatchglobal 1 singleopts {any}}}
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list runraw [list sub word$i  singleopts {any}]]
+    }
+    lappend commands  {runpwsh {match ^-c$ dispatch shellspy::do_in_powershell dispatchtype raw dispatchglobal 1 singleopts {any}}}
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list runpwsh [list sub word$i  singleopts {any}]]
+    }
+    lappend commands  {runpwsht {match ^pwsh$ dispatch shellspy::do_in_powershell_terminal dispatchtype raw dispatchglobal 1 singleopts {any}}}
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list runpwsht [list sub word$i  singleopts {any}]]
+    }
+    
+    
+    lappend commands {runcmd {match ^/c$ dispatch shellspy::do_in_cmdshell dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}}
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list runcmd [list sub word$i  singleopts {any}]]
+    }
+    lappend commands {runcmduc {match ^/u/c$ dispatch shellspy::do_in_cmdshelluc dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}}}
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list runcmduc [list sub word$i  singleopts {any}]]
+    }
+    #cmd with bracked args () e.g with vim shellxquote set to "("
+    lappend commands [list runcmdb [list match ^cmdb$ dispatch [list shellspy::do_in_cmdshellb %matched%] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any} pairopts {any}]]
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list runcmdb [list sub word$i  singleopts {any} longopts {any} pairopts {any}]]
+    }
+    
+    lappend commands  [list wslraw [list match ^wsl$ dispatch [list shellspy::do_wsl AlmaLinux9] dispatchtype raw dispatchglobal 1 singleopts {any} longopts {any}]]
+    for {set i 0} {$i < 25} {incr i} {
+    lappend commands [list wslraw [list sub word$i  singleopts {any}]]
+    }
+
+
+    ############################################################################################
+
+    #echo raw args to diverted stderr before running the argument analysis
+    puts -nonewline stderr "rawargs: $::argv\n"
+    set i 1
+    foreach a $::argv {
+        puts -nonewline stderr "arg$i: '$a'\n"
+        incr i
+    }
+    
+    
+    puts stderr $::shellfilter::ansi::test
+    flush stderr
+
+    set argdefinitions [list \
+    -caller shellspy_dispatcher \
+    -debugargs 0 \
+    -debugargsonerror 2 \
+    -return all \
+    -soloflags {} \
+    -defaults [list] \
+    -required {none} \
+    -extras {all} \
+    -commandprocessors $commands \
+    -values $::argv ]
+
+
+
+    if {[catch {
+        set arglist [check_flags {*}$argdefinitions]
+    } errMsg]} {
+        puts -nonewline stderr "|shellspy-stderr> ERROR during command dispatch\n"
+        puts -nonewline stderr "|shellspy-stderr> $errMsg\n"
+        puts -nonewline stderr "|shellspy-stderr> [set ::errorInfo]\n"
+
+    } else {
+        puts stdout "shellspy final-arglist $arglist"
+    }
+
+    shellfilter::log::write $shellspy_status_log "check_flags dispatch -done-"
+    
+    #puts stdout "sp2. $::argv"
+    
+    if {[catch {
+        set tidyinfo [shellfilter::logtidyup]
+        } errMsg]} {
+        
+        shellfilter::log::open shellspy-error {-tag shellspy-error -syslog 127.0.0.1:514}
+        shellfilter::log::write shellspy-error "logtidyup error $errMsg\n [set ::errorInfo]"
+        after 500
+    }
+    #don't open more logs.. 
+    #puts stdout ">$tidyinfo"
+    
+    
+    #shellfilter::log::write $shellspy_status_log "logtidyup -done- $tidyinfo"
+
+    
+
+    set errorlist [dict get $tidyinfo errors]
+    if {[llength $errorlist]} {
+    foreach err $errorlist {
+      puts -nonewline stderr "|shellspy-final> worker-error-set $err\n"
+    }
+    }
+    puts stdout "shellspy -done-"
+    #shellfilter::log::write $shellspy_status_log "shellspy -done-"
+    flush stdout
+    
+    if {[catch {
+        shellfilter::logtidyup $shellspy_status_log
+    } errMsg]} {
+        shellfilter::log::open shellspy-final {-tag shellspy-final -syslog 127.0.0.1:514}
+        shellfilter::log::write shellspy-final "FINAL logtidyup error $errMsg\n [set ::errorInfo]"
+        after 500
+        
+    }
+    
+    exit 0
+}
+
+}

src/punk86.vfs/lib/twapi4.7.2/LICENSE

@@ -0,0 +1,29 @@
+Copyright (c) 2003-2012, Ashok P. Nadkarni
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+- Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer.  
+
+- Redistributions in binary form must reproduce the above copyright
+notice, this list of conditions and the following disclaimer in the
+documentation and/or other materials provided with the distribution.
+
+- The name of the copyright holder and any other contributors may not
+be used to endorse or promote products derived from this software
+without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

src/punk86.vfs/lib/twapi4.7.2/adsi.tcl

@@ -0,0 +1,28 @@
+#
+# Copyright (c) 2010-2012, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# ADSI routines
+
+# TBD - document
+proc twapi::adsi_translate_name {name to {from 0}} {
+    set map {
+        unknown 0 fqdn 1 samcompatible 2 display 3 uniqueid 6
+        canonical 7 userprincipal 8 canonicalex 9 serviceprincipal 10
+        dnsdomain 12
+    }
+    if {! [string is integer -strict $to]} {
+        set to [dict get $map $to]
+        if {$to == 0} {
+            error "'unknown' is not a valid target format."
+        }
+    }
+
+    if {! [string is integer -strict $from]} {
+        set from [dict get $map $from]
+    }
+        
+    return [TranslateName $name $from $to]
+}

src/punk86.vfs/lib/twapi4.7.2/apputil.tcl

@@ -0,0 +1,114 @@
+#
+# Copyright (c) 2003-2012, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {}
+
+# Get the command line
+proc twapi::get_command_line {} {
+    return [GetCommandLineW]
+}
+
+# Parse the command line
+proc twapi::get_command_line_args {cmdline} {
+    # Special check for empty line. CommandLinetoArgv returns process
+    # exe name in this case.
+    if {[string length $cmdline] == 0} {
+        return [list ]
+    }
+    return [CommandLineToArgv $cmdline]
+}
+
+# Read an ini file int
+proc twapi::read_inifile_key {section key args} {
+    array set opts [parseargs args {
+        {default.arg ""}
+        inifile.arg
+    } -maxleftover 0]
+
+    if {[info exists opts(inifile)]} {
+        set values [read_inifile_section $section -inifile $opts(inifile)]
+    } else {
+        set values [read_inifile_section $section]
+    }
+
+    # Cannot use kl_get or arrays here because we want case insensitive compare
+    foreach {k val} $values {
+        if {[string equal -nocase $key $k]} {
+            return $val
+        }
+    }
+    return $opts(default)
+}
+
+# Write an ini file string
+proc twapi::write_inifile_key {section key value args} {
+    array set opts [parseargs args {
+        inifile.arg
+    } -maxleftover 0]
+
+    if {[info exists opts(inifile)]} {
+        WritePrivateProfileString $section $key $value $opts(inifile)
+    } else {
+        WriteProfileString $section $key $value
+    }
+}
+
+# Delete an ini file string
+proc twapi::delete_inifile_key {section key args} {
+    array set opts [parseargs args {
+        inifile.arg
+    } -maxleftover 0]
+
+    if {[info exists opts(inifile)]} {
+        WritePrivateProfileString $section $key $twapi::nullptr $opts(inifile)
+    } else {
+        WriteProfileString $section $key $twapi::nullptr
+    }
+}
+
+# Get names of the sections in an inifile
+proc twapi::read_inifile_section_names {args} {
+    array set opts [parseargs args {
+        inifile.arg
+    } -nulldefault -maxleftover 0]
+
+    return [GetPrivateProfileSectionNames $opts(inifile)]
+}
+
+# Get keys and values in a section in an inifile
+proc twapi::read_inifile_section {section args} {
+    array set opts [parseargs args {
+        inifile.arg
+    } -nulldefault -maxleftover 0]
+
+    set result [list ]
+    foreach line [GetPrivateProfileSection $section $opts(inifile)] {
+        set pos [string first "=" $line]
+        if {$pos >= 0} {
+            lappend result [string range $line 0 [expr {$pos-1}]] [string range $line [incr pos] end]
+        }
+    }
+    return $result
+}
+
+
+# Delete an ini file section
+proc twapi::delete_inifile_section {section args} {
+    variable nullptr
+
+    array set opts [parseargs args {
+        inifile.arg
+    }]
+
+    if {[info exists opts(inifile)]} {
+        WritePrivateProfileString $section $nullptr $nullptr $opts(inifile)
+    } else {
+        WriteProfileString $section $nullptr $nullptr
+    }
+}
+
+
+

src/punk86.vfs/lib/twapi4.7.2/clipboard.tcl

@@ -0,0 +1,254 @@
+#
+# Copyright (c) 2004, 2008 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# Clipboard related commands
+
+namespace eval twapi {}
+
+# Open the clipboard
+# TBD - why no mechanism to pass window handle to OpenClipboard?
+proc twapi::open_clipboard {} {
+    OpenClipboard 0
+}
+
+# Close the clipboard
+proc twapi::close_clipboard {} {
+    catch {CloseClipboard}
+    return
+}
+
+# Empty the clipboard
+proc twapi::empty_clipboard {} {
+    EmptyClipboard
+}
+
+proc twapi::_read_clipboard {fmt} {
+    # Always catch errors and close clipboard before passing exception on
+    # Also ensure memory unlocked
+    trap {
+        set h [GetClipboardData $fmt]
+        set p [GlobalLock $h]
+        set data [Twapi_ReadMemory 1 $p 0 [GlobalSize $h]]
+    } onerror {} {
+        catch {close_clipboard}
+        rethrow
+    } finally {
+        # If p exists, then we must have locked the handle
+        if {[info exists p]} {
+            GlobalUnlock $h
+        }
+    }
+    return $data
+}
+
+proc twapi::read_clipboard {fmt} {
+    trap {
+        set data [_read_clipboard $fmt]
+    } onerror {TWAPI_WIN32 1418} {
+        # Caller did not have clipboard open. Do it on its behalf
+        open_clipboard
+        trap {
+            set data [_read_clipboard $fmt]
+        } finally {
+            catch {close_clipboard}
+        }
+    }
+    return $data
+}
+
+# Read text data from the clipboard
+proc twapi::read_clipboard_text {args} {
+    array set opts [parseargs args {
+        {raw.bool 0}
+    }]
+
+    set bin [read_clipboard 13]; # 13 -> Unicode
+    # Decode Unicode and discard trailing nulls
+    set data [string trimright [encoding convertfrom unicode $bin] \0]
+    if {! $opts(raw)} {
+        set data [string map {"\r\n" "\n"} $data]
+    }
+
+    return $data
+}
+
+proc twapi::_write_clipboard {fmt data} {
+    # Always catch errors and close
+    # clipboard before passing exception on
+    trap {
+        # For byte arrays, string length does return correct size
+        # (DO NOT USE string bytelength - see Tcl docs!)
+        set len [string length $data]
+
+        # Allocate global memory
+        set mem_h [GlobalAlloc 2 $len]
+        set mem_p [GlobalLock $mem_h]
+
+        Twapi_WriteMemory 1 $mem_p 0 $len $data
+
+        # The rest of this code just to ensure we do not free
+        # memory beyond this point irrespective of error/success
+        set h $mem_h
+        unset mem_p mem_h
+        GlobalUnlock $h
+        SetClipboardData $fmt $h
+    } onerror {} {
+        catch close_clipboard
+        rethrow
+    } finally {
+        if {[info exists mem_p]} {
+            GlobalUnlock $mem_h
+        }
+        if {[info exists mem_h]} {
+            GlobalFree $mem_h
+        }
+    }
+    return
+}
+
+proc twapi::write_clipboard {fmt data} {
+    trap {
+        _write_clipboard $fmt $data
+    } onerror {TWAPI_WIN32 1418} {
+        # Caller did not have clipboard open. Do it on its behalf
+        open_clipboard
+        empty_clipboard
+        trap {
+            _write_clipboard $fmt $data
+        } finally {
+            catch close_clipboard
+        }
+    }
+    return
+}
+
+# Write text to the clipboard
+proc twapi::write_clipboard_text {data args} {
+    array set opts [parseargs args {
+        {raw.bool 0}
+    }]
+
+    # Convert \n to \r\n leaving existing \r\n alone
+    if {! $opts(raw)} {
+        set data [regsub -all {(^|[^\r])\n} $data[set data ""] \\1\r\n]
+    }
+    append data \0
+    write_clipboard 13 [encoding convertto unicode $data]; # 13 -> Unicode
+    return
+}
+
+# Get current clipboard formats
+proc twapi::get_clipboard_formats {} {
+    return [Twapi_EnumClipboardFormats]
+}
+
+# Get registered clipboard format name. Clipboard does not have to be open
+proc twapi::get_registered_clipboard_format_name {fmt} {
+    return [GetClipboardFormatName $fmt]
+}
+
+# Register a clipboard format
+proc twapi::register_clipboard_format {fmt_name} {
+    RegisterClipboardFormat $fmt_name
+}
+
+# Returns 1/0 depending on whether a format is on the clipboard. Clipboard
+# does not have to be open
+proc twapi::clipboard_format_available {fmt} {
+    return [IsClipboardFormatAvailable $fmt]
+}
+
+proc twapi::read_clipboard_paths {} { 
+    set bin [read_clipboard 15]
+    # Extract the DROPFILES header 
+    if {[binary scan $bin iiiii offset - - - unicode] != 5} { 
+        error "Invalid or unsupported clipboard CF_DROP data." 
+    } 
+    # Sanity check 
+    if {$offset >= [string length $bin]} { 
+        error "Truncated clipboard data." 
+    } 
+    if {$unicode} { 
+        set paths [encoding convertfrom unicode [string range $bin $offset end]] 
+    } else { 
+        set paths [encoding convertfrom ascii [string range $bin $offset end]] 
+    } 
+    set ret {}
+    foreach path [split $paths \0] { 
+        if {[string length $path] == 0} break; # Empty string -> end of list 
+        lappend ret [file join $path]
+    }
+    return $ret
+} 
+
+proc twapi::write_clipboard_paths {paths} { 
+    # The header for a DROPFILES path list in hex 
+    set fheader "1400000000000000000000000000000001000000" 
+    set bin [binary format H* $fheader] 
+    foreach path $paths { 
+        # Note explicit \0 so the encoded binary includes the null terminator 
+        append bin [encoding convertto unicode "[file nativename [file normalize $path]]\0"] 
+    } 
+    # A Unicode null char to terminate the list of paths 
+    append bin [encoding convertto unicode \0] 
+    write_clipboard 15 $bin 
+}
+
+# Start monitoring of the clipboard
+proc twapi::_clipboard_handler {} {
+    variable _clipboard_monitors
+
+    if {![info exists _clipboard_monitors] ||
+        [llength $_clipboard_monitors] == 0} {
+        return; # Not an error, could have deleted while already queued
+    }
+
+    foreach {id script} $_clipboard_monitors {
+        set code [catch {uplevel #0 $script} msg]
+        if {$code == 1} {
+            # Error - put in background but we do not abort
+            after 0 [list error $msg $::errorInfo $::errorCode]
+        }
+    }
+    return
+}
+
+proc twapi::start_clipboard_monitor {script} {
+    variable _clipboard_monitors
+
+    set id "clip#[TwapiId]"
+    if {![info exists _clipboard_monitors] ||
+        [llength $_clipboard_monitors] == 0} {
+        # No clipboard monitoring in progress. Start it
+        Twapi_ClipboardMonitorStart
+    }
+
+    lappend _clipboard_monitors $id $script
+    return $id
+}
+
+
+
+# Stop monitoring of the clipboard
+proc twapi::stop_clipboard_monitor {clipid} {
+    variable _clipboard_monitors
+
+    if {![info exists _clipboard_monitors]} {
+        return;                 # Should we raise an error instead?
+    }
+
+    set new_monitors {}
+    foreach {id script} $_clipboard_monitors {
+        if {$id ne $clipid} {
+            lappend new_monitors $id $script
+        }
+    }
+
+    set _clipboard_monitors $new_monitors
+    if {[llength $_clipboard_monitors] == 0} {
+        Twapi_ClipboardMonitorStop
+    }
+}

src/punk86.vfs/lib/twapi4.7.2/console.tcl

@@ -0,0 +1,736 @@
+#
+# Copyright (c) 2004-2014, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {
+}
+
+# Allocate a new console
+proc twapi::allocate_console {} {
+    AllocConsole
+}
+
+# Free a console
+proc twapi::free_console {} {
+    FreeConsole
+}
+
+# Get a console handle
+proc twapi::get_console_handle {type} {
+    switch -exact -- $type {
+        0 -
+        stdin { set fn "CONIN\$" }
+        1 -
+        stdout -
+        2 -
+        stderr { set fn "CONOUT\$" }
+        default {
+            error "Unknown console handle type '$type'"
+        }
+    }
+
+    # 0xC0000000 -> GENERIC_READ | GENERIC_WRITE
+    # 3 -> FILE_SHARE_READ | FILE_SHARE_WRITE
+    # 3 -> OPEN_EXISTING
+    return [CreateFile $fn \
+                0xC0000000 \
+                3 \
+                {{} 1} \
+                3 \
+                0 \
+                NULL]
+}
+
+proc twapi::_standard_handle_type {type} {
+    if {[string is integer -strict $type]} {
+        set type [format %d $type] ; # Convert hex etc.
+    }
+    switch -exact -- $type {
+        0 -
+        -10 -
+        stdin { set type -10 }
+        1 -
+        -11 -
+        stdout { set type -11 }
+        2 -
+        -12 -
+        stderr { set type -12 }
+        default {
+            error "Unknown console handle type '$type'"
+        }
+    }
+    return $type
+}
+
+# Get a console handle
+proc twapi::get_standard_handle {type} {
+    return [GetStdHandle [_standard_handle_type $type]]
+}
+
+# Set a console handle
+proc twapi::set_standard_handle {type handle} {
+    return [SetStdHandle [_standard_handle_type $type] $handle]
+}
+
+proc twapi::_console_output_attr_to_flags {attrs} {
+    set flags 0
+    foreach {attr bool} $attrs {
+        if {$bool} {
+            set flags [expr {$flags | [_console_output_attr $attr]}]
+        }
+    }
+    return $flags
+}
+
+proc twapi::_flags_to_console_output_attr {flags} {
+    # Check for multiple bit attributes first, in order
+    set attrs {}
+    foreach attr {
+        -fgwhite -bgwhite -fggray -bggray
+        -fgturquoise -bgturquoise -fgpurple -bgpurple -fgyellow -bgyellow
+        -fgred -bgred -fggreen -bggreen -fgblue -bgblue
+        -fgbright -bgbright
+    } {
+        if {($flags & [_console_output_attr $attr]) == [_console_output_attr $attr]} {
+            lappend attrs $attr 1
+            set flags [expr {$flags & ~ [_console_output_attr $attr]}]
+            if {$flags == 0} {
+                break
+            }
+        }
+    }
+        
+    return $attrs
+}
+
+
+# Get the current mode settings for the console
+proc twapi::_get_console_input_mode {conh} {
+    set mode [GetConsoleMode $conh]
+    return [_bitmask_to_switches $mode [_console_input_mode_syms]]
+}
+interp alias {} twapi::get_console_input_mode {} twapi::_do_console_proc twapi::_get_console_input_mode stdin
+
+# Get the current mode settings for the console
+proc twapi::_get_console_output_mode {conh} {
+    set mode [GetConsoleMode $conh]
+    return [_bitmask_to_switches $mode [_console_output_mode_syms]]
+}
+interp alias {} twapi::get_console_output_mode {} twapi::_do_console_proc twapi::_get_console_output_mode stdout
+
+# Set console input mode
+proc twapi::_set_console_input_mode {conh args} {
+    set mode [_switches_to_bitmask $args [_console_input_mode_syms]]
+    # If insertmode or quickedit mode are set, make sure to set extended bit
+    if {$mode & 0x60} {
+        setbits mode 0x80;              # ENABLE_EXTENDED_FLAGS
+    }
+
+    SetConsoleMode $conh $mode
+}
+interp alias {} twapi::set_console_input_mode {} twapi::_do_console_proc twapi::_set_console_input_mode stdin
+
+# Modify console input mode
+proc twapi::_modify_console_input_mode {conh args} {
+    set prev [GetConsoleMode $conh]
+    set mode [_switches_to_bitmask $args [_console_input_mode_syms] $prev]
+    # If insertmode or quickedit mode are set, make sure to set extended bit
+    if {$mode & 0x60} {
+        setbits mode 0x80;              # ENABLE_EXTENDED_FLAGS
+    }
+
+    SetConsoleMode $conh $mode
+    # Returns the old modes
+    return [_bitmask_to_switches $prev [_console_input_mode_syms]]
+}
+interp alias {} twapi::modify_console_input_mode {} twapi::_do_console_proc twapi::_modify_console_input_mode stdin
+
+#
+# Set console output mode
+proc twapi::_set_console_output_mode {conh args} {
+    set mode [_switches_to_bitmask $args [_console_output_mode_syms]]
+
+    SetConsoleMode $conh $mode
+
+}
+interp alias {} twapi::set_console_output_mode {} twapi::_do_console_proc twapi::_set_console_output_mode stdout
+
+# Set console output mode
+proc twapi::_modify_console_output_mode {conh args} {
+    set prev [GetConsoleMode $conh]
+    set mode [_switches_to_bitmask $args [_console_output_mode_syms] $prev]
+
+    SetConsoleMode $conh $mode
+    # Returns the old modes
+    return [_bitmask_to_switches $prev [_console_output_mode_syms]]
+}
+interp alias {} twapi::modify_console_output_mode {} twapi::_do_console_proc twapi::_modify_console_output_mode stdout
+
+
+# Create and return a handle to a screen buffer
+proc twapi::create_console_screen_buffer {args} {
+    array set opts [parseargs args {
+        {inherit.bool 0}
+        {mode.arg readwrite {read write readwrite}}
+        {secd.arg ""}
+        {share.arg readwrite {none read write readwrite}}
+    } -maxleftover 0]
+
+    switch -exact -- $opts(mode) {
+        read       { set mode [_access_rights_to_mask generic_read] }
+        write      { set mode [_access_rights_to_mask generic_write] }
+        readwrite  {
+            set mode [_access_rights_to_mask {generic_read generic_write}]
+        }
+    }
+    switch -exact -- $opts(share) {
+        none {
+            set share 0
+        }
+        read       {
+            set share 1 ;# FILE_SHARE_READ
+        }
+        write      {
+            set share 2 ;# FILE_SHARE_WRITE
+        }
+        readwrite  {
+            set share 3
+        }
+    }
+    
+    return [CreateConsoleScreenBuffer \
+                $mode \
+                $share \
+                [_make_secattr $opts(secd) $opts(inherit)] \
+                1]
+}
+
+# Retrieve information about a console screen buffer
+proc twapi::_get_console_screen_buffer_info {conh args} {
+    array set opts [parseargs args {
+        all
+        textattr
+        cursorpos
+        maxwindowsize
+        size
+        windowlocation
+        windowpos
+        windowsize
+    } -maxleftover 0]
+
+    lassign [GetConsoleScreenBufferInfo $conh] size cursorpos textattr windowlocation maxwindowsize
+
+    set result [list ]
+    foreach opt {size cursorpos maxwindowsize windowlocation} {
+        if {$opts($opt) || $opts(all)} {
+            lappend result -$opt [set $opt]
+        }
+    }
+
+    if {$opts(windowpos) || $opts(all)} {
+        lappend result -windowpos [lrange $windowlocation 0 1]
+    }
+
+    if {$opts(windowsize) || $opts(all)} {
+        lassign $windowlocation left top right bot
+        lappend result -windowsize [list [expr {$right-$left+1}] [expr {$bot-$top+1}]]
+    }
+
+    if {$opts(textattr) || $opts(all)} {
+        lappend result -textattr [_flags_to_console_output_attr $textattr]
+    }
+
+    return $result
+}
+interp alias {} twapi::get_console_screen_buffer_info {} twapi::_do_console_proc twapi::_get_console_screen_buffer_info stdout
+
+# Set the cursor position
+proc twapi::_set_console_cursor_position {conh pos} {
+    SetConsoleCursorPosition $conh $pos
+}
+interp alias {} twapi::set_console_cursor_position {} twapi::_do_console_proc twapi::_set_console_cursor_position stdout
+
+# Get the cursor position
+proc twapi::get_console_cursor_position {conh} {
+    return [lindex [get_console_screen_buffer_info $conh -cursorpos] 1]
+}
+
+# Write the specified string to the console
+proc twapi::_console_write {conh s args} {
+    # Note writes are always in raw mode, 
+    # TBD - support for  scrolling
+    # TBD - support for attributes
+
+    array set opts [parseargs args {
+        position.arg
+        {newlinemode.arg column {line column}}
+        {restoreposition.bool 0}
+    } -maxleftover 0]
+
+    # Get screen buffer info including cursor position
+    array set csbi [get_console_screen_buffer_info $conh -cursorpos -size]
+
+    # Get current console mode for later restoration
+    # If console is in processed mode, set it to raw mode
+    set oldmode [get_console_output_mode $conh]
+    set processed_index [lsearch -exact $oldmode "processed"]
+    if {$processed_index >= 0} {
+        # Console was in processed mode. Set it to raw mode
+        set newmode [lreplace $oldmode $processed_index $processed_index]
+        set_console_output_mode $conh $newmode
+    }
+    
+    trap {
+        # x,y are starting position to write
+        if {[info exists opts(position)]} {
+            lassign [_parse_integer_pair $opts(position)] x y
+        } else {
+            # No position specified, get current cursor position
+            lassign $csbi(-cursorpos) x y
+        }
+        
+        set startx [expr {$opts(newlinemode) == "column" ? $x : 0}]
+
+        # Get screen buffer limits
+        lassign  $csbi(-size)  width height
+
+        # Ensure line terminations are just \n
+        set s [string map [list \r\n \n] $s]
+
+        # Write out each line at ($x,$y)
+        # Either \r or \n is considered a newline
+        foreach line [split $s \r\n] {
+            if {$y >= $height} break
+            set_console_cursor_position $conh [list $x $y]
+            if {$x < $width} {
+                # Write the characters - do not write more than buffer width
+                set num_chars [expr {$width-$x}]
+                if {[string length $line] < $num_chars} {
+                    set num_chars [string length $line]
+                }
+                WriteConsole $conh $line $num_chars
+            }
+            
+            
+            # Calculate starting position of next line
+            incr y
+            set x $startx
+        }
+
+    } finally {
+        # Restore cursor if requested
+        if {$opts(restoreposition)} {
+            set_console_cursor_position $conh $csbi(-cursorpos)
+        }
+        # Restore output mode if changed
+        if {[info exists newmode]} {
+            set_console_output_mode $conh $oldmode
+        }
+    }
+
+    return
+}
+interp alias {} twapi::write_console {} twapi::_do_console_proc twapi::_console_write stdout
+interp alias {} twapi::console_write {} twapi::_do_console_proc twapi::_console_write stdout
+
+# Fill an area of the console with the specified attribute
+proc twapi::_fill_console {conh args} {
+    array set opts [parseargs args {
+        position.arg
+        numlines.int
+        numcols.int
+        {mode.arg column {line column}}
+        window.bool
+        fillchar.arg
+    } -ignoreunknown]
+
+    # args will now contain attribute switches if any
+    set attr [_console_output_attr_to_flags $args]
+
+    # Get screen buffer info for window and size of buffer
+    array set csbi [get_console_screen_buffer_info $conh -windowpos -windowsize -size]
+    # Height and width of the console
+    lassign $csbi(-size) conx cony
+
+    # Figure out what area we want to fill
+    # startx,starty are starting position to write
+    # sizex, sizey are the number of rows/lines
+    if {[info exists opts(window)]} {
+        if {[info exists opts(numlines)] || [info exists opts(numcols)]
+            || [info exists opts(position)]} {
+            error "Option -window cannot be used togther with options -position, -numlines or -numcols"
+        }
+        lassign  [_parse_integer_pair $csbi(-windowpos)] startx starty
+        lassign  [_parse_integer_pair $csbi(-windowsize)] sizex sizey
+    } else {
+        if {[info exists opts(position)]} {
+            lassign [_parse_integer_pair $opts(position)] startx starty
+        } else {
+            set startx 0
+            set starty 0
+        }
+        if {[info exists opts(numlines)]} {
+            set sizey $opts(numlines)
+        } else {
+            set sizey $cony
+        }
+        if {[info exists opts(numcols)]} {
+            set sizex $opts(numcols)
+        } else {
+            set sizex [expr {$conx - $startx}]
+        }
+    }
+    
+    set firstcol [expr {$opts(mode) == "column" ? $startx : 0}]
+
+    # Fill attribute at ($x,$y)
+    set x $startx
+    set y $starty
+    while {$y < $cony && $y < ($starty + $sizey)} {
+        if {$x < $conx} {
+            # Write the characters - do not write more than buffer width
+            set max [expr {$conx-$x}]
+            if {[info exists attr]} {
+                FillConsoleOutputAttribute $conh $attr [expr {$sizex > $max ? $max : $sizex}] [list $x $y]
+            }
+            if {[info exists opts(fillchar)]} {
+                FillConsoleOutputCharacter $conh $opts(fillchar) [expr {$sizex > $max ? $max : $sizex}] [list $x $y]
+            }
+        }
+        
+        # Calculate starting position of next line
+        incr y
+        set x $firstcol
+    }
+    
+    return
+}
+interp alias {} twapi::fill_console {} twapi::_do_console_proc twapi::_fill_console stdout
+
+# Clear the console
+proc twapi::_clear_console {conh args} {
+    # I support we could just call fill_console but this code was already
+    # written and is faster
+    array set opts [parseargs args {
+        {fillchar.arg " "}
+        {windowonly.bool 0}
+    } -maxleftover 0]
+
+    array set cinfo [get_console_screen_buffer_info $conh -size -windowpos -windowsize]
+    lassign  $cinfo(-size) width height
+    if {$opts(windowonly)} {
+        # Only clear portion visible in the window. We have to do this
+        # line by line since we do not want to erase text scrolled off
+        # the window either in the vertical or horizontal direction
+        lassign $cinfo(-windowpos) x y
+        lassign $cinfo(-windowsize) w h
+        for {set i 0} {$i < $h} {incr i} {
+            FillConsoleOutputCharacter \
+                $conh \
+                $opts(fillchar)  \
+                $w \
+                [list $x [expr {$y+$i}]]
+        }
+    } else {
+        FillConsoleOutputCharacter \
+            $conh \
+            $opts(fillchar)  \
+            [expr {($width*$height) }] \
+            [list 0 0]
+    }
+    return
+}
+interp alias {} twapi::clear_console {} twapi::_do_console_proc twapi::_clear_console stdout
+#
+# Flush console input
+proc twapi::_flush_console_input {conh} {
+    FlushConsoleInputBuffer $conh
+}
+interp alias {} twapi::flush_console_input {} twapi::_do_console_proc twapi::_flush_console_input stdin
+
+# Return number of pending console input events
+proc twapi::_get_console_pending_input_count {conh} {
+    return [GetNumberOfConsoleInputEvents $conh]
+}
+interp alias {} twapi::get_console_pending_input_count {} twapi::_do_console_proc twapi::_get_console_pending_input_count stdin
+
+# Generate a console control event
+proc twapi::generate_console_control_event {event {procgrp 0}} {
+    switch -exact -- $event {
+        ctrl-c {set event 0}
+        ctrl-break {set event 1}
+        default {error "Invalid event definition '$event'"}
+    }
+    GenerateConsoleCtrlEvent $event $procgrp
+}
+
+# Get number of mouse buttons
+proc twapi::num_console_mouse_buttons {} {
+    return [GetNumberOfConsoleMouseButtons]
+}
+
+# Get console title text
+proc twapi::get_console_title {} {
+    return [GetConsoleTitle]
+}
+
+# Set console title text
+proc twapi::set_console_title {title} {
+    return [SetConsoleTitle $title]
+}
+
+# Get the handle to the console window
+proc twapi::get_console_window {} {
+    return [GetConsoleWindow]
+}
+
+# Get the largest console window size
+proc twapi::_get_console_window_maxsize {conh} {
+    return [GetLargestConsoleWindowSize $conh]
+}
+interp alias {} twapi::get_console_window_maxsize {} twapi::_do_console_proc twapi::_get_console_window_maxsize stdout
+
+proc twapi::_set_console_active_screen_buffer {conh} {
+    SetConsoleActiveScreenBuffer $conh
+}
+interp alias {} twapi::set_console_active_screen_buffer {} twapi::_do_console_proc twapi::_set_console_active_screen_buffer stdout
+
+# Set the size of the console screen buffer
+proc twapi::_set_console_screen_buffer_size {conh size} {
+    SetConsoleScreenBufferSize $conh [_parse_integer_pair $size]
+}
+interp alias {} twapi::set_console_screen_buffer_size {} twapi::_do_console_proc twapi::_set_console_screen_buffer_size stdout
+
+# Set the default text attribute
+proc twapi::_set_console_default_attr {conh args} {
+    SetConsoleTextAttribute $conh [_console_output_attr_to_flags $args]
+}
+interp alias {} twapi::set_console_default_attr {} twapi::_do_console_proc twapi::_set_console_default_attr stdout
+
+# Set the console window position
+proc twapi::_set_console_window_location {conh rect args} {
+    array set opts [parseargs args {
+        {absolute.bool true}
+    } -maxleftover 0]
+
+    SetConsoleWindowInfo $conh $opts(absolute) $rect
+}
+interp alias {} twapi::set_console_window_location {} twapi::_do_console_proc twapi::_set_console_window_location stdout
+
+proc twapi::get_console_window_location {conh} {
+    return [lindex [get_console_screen_buffer_info $conh -windowlocation] 1]
+}
+
+# Get the console code page
+proc twapi::get_console_output_codepage {} {
+    return [GetConsoleOutputCP]
+}
+
+# Set the console code page
+proc twapi::set_console_output_codepage {cp} {
+    SetConsoleOutputCP $cp
+}
+
+# Get the console input code page
+proc twapi::get_console_input_codepage {} {
+    return [GetConsoleCP]
+}
+
+# Set the console input code page
+proc twapi::set_console_input_codepage {cp} {
+    SetConsoleCP $cp
+}
+
+# Read a line of input
+proc twapi::_console_read {conh args} {
+    if {[llength $args]} {
+        set oldmode [modify_console_input_mode $conh {*}$args]
+    }
+    trap {
+        return [ReadConsole $conh 1024]
+    } finally {
+        if {[info exists oldmode]} {
+            set_console_input_mode $conh {*}$oldmode
+        }
+    }
+}
+interp alias {} twapi::console_read {} twapi::_do_console_proc twapi::_console_read stdin
+
+proc twapi::_map_console_controlkeys {control} {
+    return [_make_symbolic_bitmask $control {
+        capslock 0x80
+        enhanced 0x100
+        leftalt 0x2
+        leftctrl 0x8
+        numlock 0x20
+        rightalt 0x1
+        rightctrl 4
+        scrolllock 0x40
+        shift 0x10
+    } 0]
+}
+
+proc twapi::_console_read_input_records {conh args} {
+    parseargs args {
+        {count.int 1}
+        peek
+    } -setvars -maxleftover 0
+    set recs {}
+    if {$peek} {
+        set input [PeekConsoleInput $conh $count]
+    } else {
+        set input [ReadConsoleInput $conh $count]
+    }
+    foreach rec $input {
+        switch [format %d [lindex $rec 0]] {
+            1 {
+                lassign [lindex $rec 1] keydown repeat keycode scancode char controlstate
+                lappend recs \
+                    [list key [list \
+                                   keystate [expr {$keydown ? "down" : "up"}] \
+                                   repeat $repeat keycode $keycode \
+                                   scancode $scancode char $char \
+                                   controls [_map_console_controlkeys $controlstate]]]
+            }
+            2 {
+                lassign [lindex $rec 1] position buttonstate controlstate flags
+                set buttons {}
+                if {[expr {$buttonstate & 0x1}]} {lappend buttons left}
+                if {[expr {$buttonstate & 0x2}]} {lappend buttons right}
+                if {[expr {$buttonstate & 0x4}]} {lappend buttons left2}
+                if {[expr {$buttonstate & 0x8}]} {lappend buttons left3}
+                if {[expr {$buttonstate & 0x10}]} {lappend buttons left4}
+                if {$flags & 0x8} {
+                    set horizontalwheel [expr {$buttonstate >> 16}]
+                } else {
+                    set horizontalwheel 0
+                }
+                if {$flags & 0x4} {
+                    set verticalwheel [expr {$buttonstate >> 16}]
+                } else {
+                    set verticalwheel 0
+                }
+                lappend recs \
+                    [list mouse [list \
+                                     position $position \
+                                     buttons $buttons \
+                                     controls [_map_console_controlkeys $controlstate] \
+                                     doubleclick [expr {$flags & 0x2}] \
+                                     horizontalwheel $horizontalwheel \
+                                     moved [expr {$flags & 0x1}] \
+                                     verticalwheel $verticalwheel]]
+            }
+            default {
+                lappend recs [list \
+                                  [dict* {4 buffersize 8 menu 16 focus} [lindex $rec 0]] \
+                                  [lindex $rec 1]]
+            }
+        }
+    }
+    return $recs
+}
+interp alias {} twapi::console_read_input_records {} twapi::_do_console_proc twapi::_console_read_input_records stdin
+
+# Set up a console handler
+proc twapi::_console_ctrl_handler {ctrl} {
+    variable _console_control_script
+    if {[info exists _console_control_script]} {
+        return [uplevel #0 [linsert $_console_control_script end $ctrl]]
+    }
+    return 0;                   # Not handled
+}
+proc twapi::set_console_control_handler {script} {
+    variable _console_control_script
+    if {[string length $script]} {
+        if {![info exists _console_control_script]} {
+            Twapi_ConsoleEventNotifier 1
+        }
+        set _console_control_script $script
+    } else {
+        if {[info exists _console_control_script]} {
+            Twapi_ConsoleEventNotifier 0
+            unset _console_control_script
+        }
+    }
+}
+
+# 
+# Utilities
+#
+
+# Helper to call a proc after doing a stdin/stdout/stderr -> handle
+# mapping. The handle is closed after calling the proc. The first
+# arg in $args must be the console handle if $args is not an empty list
+proc twapi::_do_console_proc {proc default args} {
+    if {[llength $args] == 0} {
+        set args [list $default]
+    }
+    set conh [lindex $args 0]
+    switch -exact -- [string tolower $conh] {
+        stdin  -
+        stdout -
+        stderr {
+            set real_handle [get_console_handle $conh]
+            trap {
+                lset args 0 $real_handle
+                return [uplevel 1 [list $proc] $args]
+            } finally {
+                CloseHandle $real_handle
+            }
+        }
+    }
+    
+    return [uplevel 1 [list $proc] $args]
+}
+
+proc twapi::_console_input_mode_syms {} {
+    return {
+        -processedinput 0x0001
+        -lineinput      0x0002
+        -echoinput      0x0004
+        -windowinput    0x0008
+        -mouseinput     0x0010
+        -insertmode     0x0020
+        -quickeditmode  0x0040
+        -extendedmode   0x0080
+        -autoposition   0x0100
+    }
+}
+
+proc twapi::_console_output_mode_syms {} {
+    return { -processedoutput 1 -wrapoutput 2 }
+}
+
+twapi::proc* twapi::_console_output_attr {sym} {
+    variable _console_output_attr_syms
+    array set _console_output_attr_syms {
+        -fgblue 1
+        -fggreen 2
+        -fgturquoise 3
+        -fgred 4
+        -fgpurple 5
+        -fgyellow 6
+        -fggray 7
+        -fgbright 8
+        -fgwhite 15
+        -bgblue 16
+        -bggreen 32
+        -bgturquoise 48
+        -bgred 64
+        -bgpurple 80
+        -bgyellow 96
+        -bggray 112
+        -bgbright 128
+        -bgwhite 240
+    }
+} {
+    variable _console_output_attr_syms
+    if {[info exists _console_output_attr_syms($sym)]} {
+        return $_console_output_attr_syms($sym)
+    }
+
+    badargs! "Invalid console output attribute '$sym'" 3
+}
+

src/punk86.vfs/lib/twapi4.7.2/device.tcl

@@ -0,0 +1,624 @@
+#
+# Copyright (c) 2008-2014 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {
+    struct _PREVENT_MEDIA_REMOVAL {
+            BOOLEAN PreventMediaRemoval;
+    }
+    record device_element { class_guid device_instance reserved }
+}
+
+interp alias {} close_devinfoset {} devinfoset_close
+
+proc twapi::rescan_devices {} {
+    CM_Reenumerate_DevNode_Ex [CM_Locate_DevNode_Ex "" 0] 0
+}
+
+
+# Callback invoked for device changes.
+# Does some processing of passed data and then invokes the
+# real callback script
+proc twapi::_device_notification_handler {id args} {
+    variable _device_notifiers
+    set idstr "devnotifier#$id"
+    if {![info exists _device_notifiers($idstr)]} {
+        # Notifications that expect a response default to "true"
+        return 1
+    }
+    set script [lindex $_device_notifiers($idstr) 1]
+
+    # For volume notifications, change drive bitmask to
+    # list of drives before passing back to script
+    set event [lindex $args 0]
+    if {[lindex $args 1] eq "volume" &&
+        ($event eq "deviceremovecomplete" || $event eq "devicearrival")} {
+        lset args 2 [_drivemask_to_drivelist [lindex $args 2]]
+
+        # Also indicate whether network volume and whether change is a media
+        # change or physical change
+        set attrs [list ]
+        set flags [lindex $args 3]
+        if {$flags & 1} {
+            lappend attrs mediachange
+        }
+        if {$flags & 2} {
+            lappend attrs networkvolume
+        }
+        lset args 3 $attrs
+    }
+
+    return [uplevel #0 [linsert $script end $idstr {*}$args]]
+}
+
+proc twapi::start_device_notifier {script args} {
+    variable _device_notifiers
+
+    set script [lrange $script 0 end]; # Verify syntactically a list
+
+    array set opts [parseargs args {
+        deviceinterface.arg
+        handle.arg
+    } -maxleftover 0]
+
+    # For reference - some common device interface classes
+    # NOTE: NOT ALL HAVE BEEN VERIFIED!
+    # Network Card      {ad498944-762f-11d0-8dcb-00c04fc3358c}
+    # Human Interface Device (HID)      {4d1e55b2-f16f-11cf-88cb-001111000030}
+    # GUID_DEVINTERFACE_DISK          - {53f56307-b6bf-11d0-94f2-00a0c91efb8b}
+    # GUID_DEVINTERFACE_CDROM         - {53f56308-b6bf-11d0-94f2-00a0c91efb8b}
+    # GUID_DEVINTERFACE_PARTITION     - {53f5630a-b6bf-11d0-94f2-00a0c91efb8b}
+    # GUID_DEVINTERFACE_TAPE          - {53f5630b-b6bf-11d0-94f2-00a0c91efb8b}
+    # GUID_DEVINTERFACE_WRITEONCEDISK - {53f5630c-b6bf-11d0-94f2-00a0c91efb8b}
+    # GUID_DEVINTERFACE_VOLUME        - {53f5630d-b6bf-11d0-94f2-00a0c91efb8b}
+    # GUID_DEVINTERFACE_MEDIUMCHANGER - {53f56310-b6bf-11d0-94f2-00a0c91efb8b}
+    # GUID_DEVINTERFACE_FLOPPY        - {53f56311-b6bf-11d0-94f2-00a0c91efb8b}
+    # GUID_DEVINTERFACE_CDCHANGER     - {53f56312-b6bf-11d0-94f2-00a0c91efb8b}
+    # GUID_DEVINTERFACE_STORAGEPORT   - {2accfe60-c130-11d2-b082-00a0c91efb8b}
+    # GUID_DEVINTERFACE_KEYBOARD      - {884b96c3-56ef-11d1-bc8c-00a0c91405dd}
+    # GUID_DEVINTERFACE_MOUSE         - {378de44c-56ef-11d1-bc8c-00a0c91405dd}
+    # GUID_DEVINTERFACE_PARALLEL      - {97F76EF0-F883-11D0-AF1F-0000F800845C}
+    # GUID_DEVINTERFACE_COMPORT       - {86e0d1e0-8089-11d0-9ce4-08003e301f73}
+    # GUID_DEVINTERFACE_DISPLAY_ADAPTER - {5b45201d-f2f2-4f3b-85bb-30ff1f953599}
+    # GUID_DEVINTERFACE_USB_HUB       - {f18a0e88-c30c-11d0-8815-00a0c906bed8}
+    # GUID_DEVINTERFACE_USB_DEVICE    - {A5DCBF10-6530-11D2-901F-00C04FB951ED}
+    # GUID_DEVINTERFACE_USB_HOST_CONTROLLER - {3abf6f2d-71c4-462a-8a92-1e6861e6af27}
+
+
+    if {[info exists opts(deviceinterface)] && [info exists opts(handle)]} {
+        error "Options -deviceinterface and -handle are mutually exclusive."
+    }
+
+    if {![info exists opts(deviceinterface)]} {
+        set opts(deviceinterface) ""
+    }
+    if {[info exists opts(handle)]} {
+        set type 6
+    } else {
+        set opts(handle) NULL
+        switch -exact -- $opts(deviceinterface) {
+            port            { set type 3 ; set opts(deviceinterface) "" }
+            volume          { set type 2 ; set opts(deviceinterface) "" }
+            default {
+                # device interface class guid or empty string (for all device interfaces)
+                set type 5
+            }
+        }
+    }
+
+    set id [Twapi_RegisterDeviceNotification $type $opts(deviceinterface) $opts(handle)]
+    set idstr "devnotifier#$id"
+
+    set _device_notifiers($idstr) [list $id $script]
+    return $idstr
+}
+
+proc twapi::stop_device_notifier {idstr} {
+    variable _device_notifiers
+
+    if {![info exists _device_notifiers($idstr)]} {
+        return;
+    }
+
+    Twapi_UnregisterDeviceNotification [lindex $_device_notifiers($idstr) 0]
+    unset _device_notifiers($idstr)
+}
+
+proc twapi::devinfoset {args} {
+    array set opts [parseargs args {
+        {guid.arg ""}
+        {classtype.arg setup {interface setup}}
+        {presentonly.bool false 0x2}
+        {currentprofileonly.bool false 0x8}
+        {deviceinfoset.arg NULL}
+        {hwin.int 0}
+        {system.arg ""}
+        {pnpenumerator.arg ""}
+    } -maxleftover 0]
+
+    # DIGCF_ALLCLASSES is bitmask 4
+    set flags [expr {$opts(guid) eq "" ? 0x4 : 0}]
+    if {$opts(classtype) eq "interface"} {
+        if {$opts(pnpenumerator) ne ""} {
+            error "The -pnpenumerator option cannot be used when -classtype interface is specified."
+        }
+        # DIGCF_DEVICEINTERFACE
+        set flags [expr {$flags | 0x10}]
+    }
+
+    # DIGCF_PRESENT
+    set flags [expr {$flags | $opts(presentonly)}]
+
+    # DIGCF_PRESENT
+    set flags [expr {$flags | $opts(currentprofileonly)}]
+
+    return [SetupDiGetClassDevsEx \
+                $opts(guid) \
+                $opts(pnpenumerator) \
+                $opts(hwin) \
+                $flags \
+                $opts(deviceinfoset) \
+                $opts(system)]
+}
+
+
+# Given a device information set, returns the device elements within it
+proc twapi::devinfoset_elements {hdevinfo} {
+    set result [list ]
+    set i 0
+    trap {
+        while {true} {
+            lappend result [SetupDiEnumDeviceInfo $hdevinfo $i]
+            incr i
+        }
+    } onerror {TWAPI_WIN32 0x103} {
+        # Fine, Just means no more items
+    } onerror {TWAPI_WIN32 0x80070103} {
+        # Fine, Just means no more items (HRESULT version of above code)
+    }
+
+    return $result
+}
+
+# Given a device information set, returns the device elements within it
+proc twapi::devinfoset_instance_ids {hdevinfo} {
+    set result [list ]
+    set i 0
+    trap {
+        while {true} {
+            lappend result [device_element_instance_id $hdevinfo [SetupDiEnumDeviceInfo $hdevinfo $i]]
+            incr i
+        }
+    } onerror {TWAPI_WIN32 0x103} {
+        # Fine, Just means no more items
+    } onerror {TWAPI_WIN32 0x80070103} {
+        # Fine, Just means no more items (HRESULT version of above code)
+    }
+
+    return $result
+}
+
+# Returns a device instance element from a devinfoset
+proc twapi::devinfoset_element {hdevinfo instance_id} {
+    return [SetupDiOpenDeviceInfo $hdevinfo $instance_id 0 0]
+}
+
+# Get the registry property for a devinfoset element
+proc twapi::devinfoset_element_registry_property {hdevinfo develem prop} {
+    Twapi_SetupDiGetDeviceRegistryProperty $hdevinfo $develem [_device_registry_sym_to_code $prop]
+}
+
+# Given a device information set, returns a list of specified registry
+# properties for all elements of the set
+# args is list of properties to retrieve
+proc twapi::devinfoset_registry_properties {hdevinfo args} {
+    set result [list ]
+    trap {
+        # Keep looping until there is an error saying no more items
+        set i 0
+        while {true} {
+
+            # First element is the DEVINFO_DATA element
+            set devinfo_data [SetupDiEnumDeviceInfo $hdevinfo $i]
+            set item [list -deviceelement $devinfo_data ]
+
+            # Get all specified property values
+            foreach prop $args {
+                set intprop [_device_registry_sym_to_code $prop]
+                trap {
+                    lappend item $prop \
+                        [list success \
+                             [Twapi_SetupDiGetDeviceRegistryProperty \
+                                  $hdevinfo $devinfo_data $intprop]]
+                } onerror {} {
+                    lappend item $prop [list fail [list [trapresult] $::errorCode]]
+                }
+            }
+            lappend result $item
+
+            incr i
+        }
+    } onerror {TWAPI_WIN32 0x103} {
+        # Fine, Just means no more items
+    } onerror {TWAPI_WIN32 0x80070103} {
+        # Fine, Just means no more items (HRESULT version of above code)
+    }
+
+    return $result
+}
+
+
+# Given a device information set, returns specified device interface
+# properties
+# TBD - document ?
+proc twapi::devinfoset_interface_details {hdevinfo guid args} {
+    set result [list ]
+
+    array set opts [parseargs args {
+        {matchdeviceelement.arg {}}
+        interfaceclass
+        flags
+        devicepath
+        deviceelement
+        ignoreerrors
+    } -maxleftover 0]
+
+    trap {
+        # Keep looping until there is an error saying no more items
+        set i 0
+        while {true} {
+            set interface_data [SetupDiEnumDeviceInterfaces $hdevinfo \
+                                    $opts(matchdeviceelement) $guid $i]
+            set item [list ]
+            if {$opts(interfaceclass)} {
+                lappend item -interfaceclass [lindex $interface_data 0]
+            }
+            if {$opts(flags)} {
+                set flags    [lindex $interface_data 1]
+                set symflags [_make_symbolic_bitmask $flags {active 1 default 2 removed 4} false]
+                lappend item -flags [linsert $symflags 0 $flags]
+            }
+
+            if {$opts(devicepath) || $opts(deviceelement)} {
+                # Need to get device interface detail.
+                trap {
+                    foreach {devicepath deviceelement} \
+                        [SetupDiGetDeviceInterfaceDetail \
+                             $hdevinfo \
+                             $interface_data \
+                             $opts(matchdeviceelement)] \
+                        break
+
+                    if {$opts(deviceelement)} {
+                        lappend item -deviceelement $deviceelement
+                    }
+                    if {$opts(devicepath)} {
+                        lappend item -devicepath $devicepath
+                    }
+                } onerror {} {
+                    if {! $opts(ignoreerrors)} {
+                        rethrow
+                    }
+                }
+            }
+            lappend result $item
+
+            incr i
+        }
+    } onerror {TWAPI_WIN32 0x103} {
+        # Fine, Just means no more items
+    } onerror {TWAPI_WIN32 0x80070103} {
+        # Fine, Just means no more items (HRESULT version of above code)
+    }
+
+    return $result
+}
+
+
+# Return the guids associated with a device class set name. Note
+# the latter is not unique so multiple guids may be associated.
+proc twapi::device_setup_class_name_to_guids {name args} {
+    array set opts [parseargs args {
+        system.arg
+    } -maxleftover 0 -nulldefault]
+
+    return [twapi::SetupDiClassGuidsFromNameEx $name $opts(system)]
+}
+
+# Utility functions
+
+proc twapi::_init_device_registry_code_maps {} {
+    variable _device_registry_syms
+    variable _device_registry_codes
+
+    # Note this list is ordered based on the corresponding integer codes
+    set _device_registry_code_syms {
+        devicedesc hardwareid compatibleids unused0 service unused1
+        unused2 class classguid driver configflags mfg friendlyname
+        location_information physical_device_object_name capabilities
+        ui_number upperfilters lowerfilters
+        bustypeguid legacybustype busnumber enumerator_name security
+        security_sds devtype exclusive characteristics address
+        ui_number_desc_format device_power_data
+        removal_policy removal_policy_hw_default removal_policy_override
+        install_state location_paths base_containerid
+    }
+
+    set i 0
+    foreach sym $_device_registry_code_syms {
+        set _device_registry_codes($sym) $i
+        incr i
+    }
+}
+
+# Map a device registry property to a symbol
+proc twapi::_device_registry_code_to_sym {code} {
+    _init_device_registry_code_maps
+
+    # Once we have initialized, redefine ourselves so we do not do so
+    # every time. Note define at global ::twapi scope!
+    proc ::twapi::_device_registry_code_to_sym {code} {
+        variable _device_registry_code_syms
+        if {$code >= [llength $_device_registry_code_syms]} {
+            return $code
+        } else {
+            return [lindex $_device_registry_code_syms $code]
+        }
+    }
+    # Call the redefined proc
+    return [_device_registry_code_to_sym $code]
+}
+
+# Map a device registry property symbol to a numeric code
+proc twapi::_device_registry_sym_to_code {sym} {
+    _init_device_registry_code_maps
+
+    # Once we have initialized, redefine ourselves so we do not do so
+    # every time. Note define at global ::twapi scope!
+    proc ::twapi::_device_registry_sym_to_code {sym} {
+        variable _device_registry_codes
+        # Return the value. If non-existent, an error will be raised
+        if {[info exists _device_registry_codes($sym)]} {
+            return $_device_registry_codes($sym)
+        } elseif {[string is integer -strict $sym]} {
+            return $sym
+        } else {
+            error "Unknown or unsupported device registry property symbol '$sym'"
+        }
+    }
+    # Call the redefined proc
+    return [_device_registry_sym_to_code $sym]
+}
+
+# Do a device ioctl, returning result as a binary
+# TBD - document that caller has to handle errors 122 (ERROR_INSUFFICIENT_BUFFER) and (ERROR_MORE_DATA)
+proc twapi::device_ioctl {h code args} {
+    array set opts [parseargs args {
+        {input.arg {}}
+        {outputcount.int 0}
+    } -maxleftover 0]
+
+    return [DeviceIoControl $h $code $opts(input) $opts(outputcount)]
+}
+
+
+# Return a list of physical disks. Note CD-ROMs and floppies not included
+proc twapi::find_physical_disks {} {
+    # Disk interface class guid
+    set guid {{53F56307-B6BF-11D0-94F2-00A0C91EFB8B}}
+    set hdevinfo [devinfoset \
+                      -guid $guid \
+                      -presentonly true \
+                      -classtype interface]
+    trap {
+        return [kl_flatten [devinfoset_interface_details $hdevinfo $guid -devicepath] -devicepath]
+    } finally {
+        devinfoset_close $hdevinfo
+    }
+}
+
+# Return information about a physical disk
+proc twapi::get_physical_disk_info {disk args} {
+    set result [list ]
+
+    array set opts [parseargs args {
+        geometry
+        layout
+        all
+    } -maxleftover 0]
+
+    if {$opts(all) || $opts(geometry) || $opts(layout)} {
+        set h [create_file $disk -createdisposition open_existing]
+    }
+
+    trap {
+        if {$opts(all) || $opts(geometry)} {
+            # IOCTL_DISK_GET_DRIVE_GEOMETRY - 0x70000
+            if {[binary scan [device_ioctl $h 0x70000 -outputcount 24] "wiiii" geom(-cylinders) geom(-mediatype) geom(-trackspercylinder) geom(-sectorspertrack) geom(-bytespersector)] != 5} {
+                error "DeviceIoControl 0x70000 on disk '$disk' returned insufficient data."
+            }
+            lappend result -geometry [array get geom]
+        }
+
+        if {$opts(all) || $opts(layout)} {
+            # XP and later - IOCTL_DISK_GET_DRIVE_LAYOUT_EX
+            set data [device_ioctl $h 0x70050 -outputcount 624]
+            if {[binary scan $data "i i" partstyle layout(-partitioncount)] != 2} {
+                error "DeviceIoControl 0x70050 on disk '$disk' returned insufficient data."
+            }
+            set layout(-partitionstyle) [_partition_style_sym $partstyle]
+            switch -exact -- $layout(-partitionstyle) {
+                mbr {
+                    if {[binary scan $data "@8 i" layout(-signature)] != 1} {
+                        error "DeviceIoControl 0x70050 on disk '$disk' returned insufficient data."
+                    }
+                }
+                gpt {
+                    set pi(-diskid) [_binary_to_guid $data 32]
+                    if {[binary scan $data "@8 w w i" layout(-startingusableoffset) layout(-usablelength) layout(-maxpartitioncount)] != 3} {
+                        error "DeviceIoControl 0x70050 on disk '$disk' returned insufficient data."
+                    }
+                }
+                raw -
+                unknown {
+                    # No fields to add
+                }
+            }
+
+            set layout(-partitions) [list ]
+            for {set i 0} {$i < $layout(-partitioncount)} {incr i} {
+                # Decode each partition in turn. Sizeof of PARTITION_INFORMATION_EX is 144
+                lappend layout(-partitions) [_decode_PARTITION_INFORMATION_EX_binary $data [expr {48 + (144*$i)}]]
+            }
+            lappend result -layout [array get layout]
+        }
+
+    } finally {
+        if {[info exists h]} {
+            CloseHandle $h
+        }
+    }
+
+    return $result
+}
+
+# Given a Tcl binary and offset, decode the PARTITION_INFORMATION_EX record
+proc twapi::_decode_PARTITION_INFORMATION_EX_binary {bin off} {
+    if {[binary scan $bin "@$off i x4 w w i c" \
+             pi(-partitionstyle) \
+             pi(-startingoffset) \
+             pi(-partitionlength) \
+             pi(-partitionnumber) \
+             pi(-rewritepartition)] != 5} {
+        error "Truncated partition structure."
+    }
+
+    set pi(-partitionstyle) [_partition_style_sym $pi(-partitionstyle)]
+
+    # MBR/GPT are at offset 32 in the structure
+    switch -exact -- $pi(-partitionstyle) {
+        mbr {
+            if {[binary scan $bin "@$off x32 c c c x i" pi(-partitiontype) pi(-bootindicator) pi(-recognizedpartition) pi(-hiddensectors)] != 4} {
+                error "Truncated partition structure."
+            }
+            # Show partition type in hex, not negative number
+            set pi(-partitiontype) [format 0x%2.2x [expr {0xff & $pi(-partitiontype)}]]
+        }
+        gpt {
+            set pi(-partitiontype) [_binary_to_guid $bin [expr {$off+32}]]
+            set pi(-partitionif)   [_binary_to_guid $bin [expr {$off+48}]]
+            if {[binary scan $bin "@$off x64 w" pi(-attributes)] != 1} {
+                error "Truncated partition structure."
+            }
+            set pi(-name) [_ucs16_binary_to_string [string range $bin [expr {$off+72}] end]]
+        }
+        raw -
+        unknown {
+            # No fields to add
+        }
+
+    }
+
+    return [array get pi]
+}
+
+#  IOCTL_STORAGE_EJECT_MEDIA
+interp alias {} twapi::eject {} twapi::eject_media
+proc twapi::eject_media device {
+    # http://support.microsoft.com/default.aspx?scid=KB;EN-US;Q165721&
+    set h [_open_disk_device $device]
+    trap {
+        device_ioctl $h 0x90018; # FSCTL_LOCK_VOLUME
+        device_ioctl $h 0x90020; # FSCTL_DISMOUNT_VOLUME
+        #  IOCTL_STORAGE_MEDIA_REMOVAL (0)
+        device_ioctl $h 0x2d4804 -input [_PREVENT_MEDIA_REMOVAL 0]
+        device_ioctl $h 0x2d4808; # IOCTL_STORAGE_EJECT_MEDIA
+    } finally {
+        close_handle $h
+    }
+}
+
+# IOCTL_DISK_LOAD_MEDIA
+# TBD - should we use IOCTL_DISK_LOAD_MEDIA2 instead (0x2d080c) see
+# SDK, faster if read / write access not necessary. We are closing
+# the handle right away anyway but would that stop other apps from
+# acessing the file system on the CD ? Need to try (note device
+# has to be opened with FILE_READ_ATTRIBUTES only in that case)
+
+interp alias {} twapi::load_media {} twapi::_issue_disk_ioctl 0x2d480c
+
+#  FSCTL_LOCK_VOLUME
+# TBD - interp alias {} twapi::lock_volume {} twapi::_issue_disk_ioctl 0x90018
+#  FSCTL_LOCK_VOLUME
+# TBD - interp alias {} twapi::unlock_volume {} twapi::_issue_disk_ioctl 0x9001c
+
+proc twapi::_lock_media {lock device} {
+    # IOCTL_STORAGE_MEDIA_REMOVAL
+    _issue_disk_ioctl 0x2d4804 $device -input [_PREVENT_MEDIA_REMOVAL $lock]
+}
+interp alias {} twapi::lock_media {} twapi::_lock_media 1
+interp alias {} twapi::unlock_media {} twapi::_lock_media 0
+
+proc twapi::_issue_disk_ioctl {ioctl device args} {
+    set h [_open_disk_device $device]
+    trap {
+        device_ioctl $h $ioctl {*}$args
+    } finally {
+        close_handle $h
+    }
+}
+
+twapi::proc* twapi::_open_disk_device {device} {
+    package require twapi_storage
+} {
+    # device must be "cdrom", X:, X:\\, X:/, a volume or a physical disk as 
+    # returned from find_physical_disks
+    switch -regexp -nocase -- $device {
+        {^cdrom$} {
+            foreach drive [find_logical_drives] {
+                if {![catch {get_drive_type $drive} drive_type]} {
+                    if {$drive_type eq "cdrom"} {
+                        set device "\\\\.\\$drive"
+                        break
+                    }
+                }
+            }
+            if {$device eq "cdrom"} {
+                error "Could not find a CD-ROM device."
+            }
+        }
+        {^[[:alpha:]]:(/|\\)?$} { 
+            set device "\\\\.\\[string range $device 0 1]"
+        }
+        {^\\\\\?\\.*#\{[[:xdigit:]]{8}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{12}\}$} {
+            # Device name ok
+        }
+        {^\\\\\?\\Volume\{[[:xdigit:]]{8}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{12}\}\\?$} {
+            # Volume name ok. But make sure we trim off any trailing 
+            # \ since create_file will open the root dir instead of the device
+            set device [string trimright $device \\]
+        }
+        default {
+            # Just to prevent us from opening some file instead
+            error "Invalid device name '$device'"
+        }
+    }
+
+    # http://support.microsoft.com/default.aspx?scid=KB;EN-US;Q165721&
+    return [create_file $device -access {generic_read generic_write} \
+                -createdisposition open_existing \
+                -share {read write}]
+}
+
+
+# Map a partition style code to a symbol
+proc twapi::_partition_style_sym {partstyle} {
+    set partstyle [lindex {mbr gpt raw} $partstyle]
+    if {$partstyle ne ""} {
+        return $partstyle
+    }
+    return "unknown"
+}
+

src/punk86.vfs/lib/twapi4.7.2/eventlog.tcl

@@ -0,0 +1,391 @@
+#
+# Copyright (c) 2004-2012, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+package require registry
+
+namespace eval twapi {
+    # We maintain caches so we do not do lookups all the time
+    # TBD - have a means of clearing this out
+    variable _eventlog_message_cache
+    set _eventlog_message_cache {}
+}
+
+
+# Read the event log
+proc twapi::eventlog_read {hevl args} {
+    _eventlog_valid_handle $hevl read raise
+
+    array set opts [parseargs args {
+        seek.int
+        {direction.arg forward}
+    }]
+
+    if {[info exists opts(seek)]} {
+        set flags 2;                    # Seek
+        set offset $opts(seek)
+    } else {
+        set flags 1;                    # Sequential read
+        set offset 0
+    }
+
+    switch -glob -- $opts(direction) {
+        ""    -
+        forw* {
+            setbits flags 4
+        }
+        back* {
+            setbits flags 8
+        }
+        default {
+            error "Invalid value '$opts(direction)' for -direction option"
+        }
+    }
+
+    set results [list ]
+
+    trap {
+        set recs [ReadEventLog $hevl $flags $offset]
+    } onerror {TWAPI_WIN32 38} {
+        # EOF - no more
+        set recs [list ]
+    }
+    foreach event $recs {
+        dict set event -type [string map {0 success 1 error 2 warning 4 information 8 auditsuccess 16 auditfailure} [dict get $event -level]]
+        lappend results $event
+    }
+
+    return $results
+}
+
+
+# Get the oldest event log record index. $hevl must be read handle
+proc twapi::eventlog_oldest {hevl} {
+    _eventlog_valid_handle $hevl read raise
+    return [GetOldestEventLogRecord $hevl]
+}
+
+# Get the event log record count. $hevl must be read handle
+proc twapi::eventlog_count {hevl} {
+    _eventlog_valid_handle $hevl read raise
+    return [GetNumberOfEventLogRecords $hevl]
+}
+
+# Check if the event log is full. $hevl may be either read or write handle
+# (only win2k plus)
+proc twapi::eventlog_is_full {hevl} {
+    # Does not matter if $hevl is read or write, but verify it is a handle
+    _eventlog_valid_handle $hevl read
+    return [Twapi_IsEventLogFull $hevl]
+}
+
+# Backup the event log
+proc twapi::eventlog_backup {hevl file} {
+    _eventlog_valid_handle $hevl read raise
+    BackupEventLog $hevl $file
+}
+
+# Clear the event log
+proc twapi::eventlog_clear {hevl args} {
+    _eventlog_valid_handle $hevl read raise
+    array set opts [parseargs args {backup.arg} -nulldefault]
+    ClearEventLog $hevl $opts(backup)
+}
+
+
+# Formats the given event log record message
+# 
+proc twapi::eventlog_format_message {rec args} {
+    variable _eventlog_message_cache
+
+    array set opts [parseargs args {
+        width.int
+        langid.int
+    } -nulldefault]
+
+    set source  [dict get $rec -source]
+    set eventid [dict get $rec -eventid]
+
+    if {[dict exists $_eventlog_message_cache $source fmtstring $opts(langid) $eventid]} {
+        set fmtstring [dict get $_eventlog_message_cache $source fmtstring $opts(langid) $eventid]
+        dict incr _eventlog_message_cache __fmtstring_hits
+    } else {
+        dict incr _eventlog_message_cache __fmtstring_misses
+
+        # Find the registry key if we do not have it already
+        if {[dict exists $_eventlog_message_cache $source regkey]} {
+            dict incr _eventlog_message_cache __regkey_hits
+            set regkey [dict get $_eventlog_message_cache $source regkey]
+        } else {
+            set regkey [_find_eventlog_regkey $source]
+            dict set _eventlog_message_cache $source regkey $regkey
+            dict incr _eventlog_message_cache __regkey_misses
+        }
+
+        # Get the message file, if there is one
+        if {! [catch {registry get $regkey "EventMessageFile"} path]} {
+            # Try each file listed in turn
+            foreach dll [split $path \;] {
+                set dll [expand_environment_strings $dll]
+                if {! [catch {
+                    set fmtstring [format_message -module $dll -messageid $eventid -width $opts(width) -langid $opts(langid)]
+                } msg]} {
+                    dict set _eventlog_message_cache $source fmtstring $opts(langid) $eventid $fmtstring
+                    break
+                }
+            }
+        }
+    }
+
+    if {! [info exists fmtstring]} {
+        dict incr _eventlog_message_cache __notfound
+
+        set fmt "The message file or event definition for event id [dict get $rec -eventid] from source [dict get $rec -source] was not found. The following information was part of the event: "
+        set flds [list ]
+        for {set i 1} {$i <= [llength [dict get $rec -params]]} {incr i} {
+            lappend flds %$i
+        }
+        append fmt [join $flds ", "]
+        return [format_message -fmtstring $fmt  \
+                    -params [dict get $rec -params] -width $opts(width)]
+    }
+
+    set msg [format_message -fmtstring $fmtstring -params [dict get $rec -params]]
+
+    # We'd found a message from the message file and replaced the string
+    # parameters. Now fill in the parameter file values if any. Note these are
+    # separate from the string parameters passed in through rec(-params)
+
+    # First check if the formatted string itself still has placeholders
+    # Place holder for the parameters file are supposed to start
+    # with two % chars. Unfortunately, not all apps, even Microsoft's own
+    # DCOM obey this. So check for both % and %%
+    set placeholder_indices [regexp -indices -all -inline {%?%\d+} $msg]
+    if {[llength $placeholder_indices] == 0} {
+        # No placeholders.
+        return $msg
+    }
+
+    # Loop through to replace placeholders.
+    set msg2 "";                # Holds result after param replacement
+    set prev_end 0
+    foreach placeholder $placeholder_indices {
+        lassign $placeholder start end
+        # Append the stuff between previous placeholder and this one
+        append msg2 [string range $msg $prev_end [expr {$start-1}]]
+        set repl [string range $msg $start $end]; # Default if not found
+        set paramid [string trimleft $repl %];     # Skip "%"
+        if {[dict exists $_eventlog_message_cache $source paramstring $opts(langid) $paramid]} {
+            dict incr _eventlog_message_cache __paramstring_hits
+            set repl [format_message -fmtstring [dict get $_eventlog_message_cache $source paramstring $opts(langid) $paramid] -params [dict get $rec -params]]
+        } else {
+            dict incr _eventlog_message_cache __paramstring_misses
+            # Not in cache, need to look up
+            if {![info exists paramfiles]} {
+                # Construct list of parameter string files
+
+                # TBD - cache registry key results?
+                # Find the registry key if we do not have it already
+                if {![info exists regkey]} {
+                    if {[dict exists $_eventlog_message_cache $source regkey]} {
+                        dict incr _eventlog_message_cache __regkey_hits
+                        set regkey [dict get $_eventlog_message_cache $source regkey]
+                    } else {
+                        dict incr _eventlog_message_cache __regkey_misses
+                        set regkey [_find_eventlog_regkey $source]
+                        dict set _eventlog_message_cache $source regkey $regkey
+                    }
+                }
+                set paramfiles {}
+                if {! [catch {registry get $regkey "ParameterMessageFile"} path]} {
+                    # Loop through every placeholder, look for the entry in the
+                    # parameters file and replace it if found
+                    foreach paramfile [split $path \;] {
+                        lappend paramfiles [expand_environment_strings $paramfile]
+                    }
+                }
+            }
+            # Try each file listed in turn
+            foreach paramfile $paramfiles {
+                if {! [catch {
+                    set paramstring [string trimright [format_message -module $paramfile -messageid $paramid -langid $opts(langid)] \r\n]
+                } ]} {
+                    # Found the replacement
+                    dict set _eventlog_message_cache $source paramstring $opts(langid) $paramid $paramstring
+                    set repl [format_message -fmtstring $paramstring -params [dict get $rec -params]]
+                    break
+                }
+            }
+        }
+        append msg2 $repl
+        set prev_end [incr end]
+    }
+    
+    # Tack on tail after last placeholder
+    append msg2 [string range $msg $prev_end end]
+    return $msg2
+}
+
+# Format the category
+proc twapi::eventlog_format_category {rec args} {
+
+    array set opts [parseargs args {
+        width.int
+        langid.int
+    } -nulldefault]
+
+    set category [dict get $rec -category]
+    if {$category == 0} {
+        return ""
+    }
+
+    variable _eventlog_message_cache
+
+    set source  [dict get $rec -source]
+
+    # Get the category string from cache, if there is one
+    if {[dict exists $_eventlog_message_cache $source category $opts(langid) $category]} {
+        dict incr _eventlog_message_cache __category_hits
+        set fmtstring [dict get $_eventlog_message_cache $source category $opts(langid) $category]
+    } else {
+        dict incr _eventlog_message_cache __category_misses
+
+        # Find the registry key if we do not have it already
+        if {[dict exists $_eventlog_message_cache $source regkey]} {
+            dict incr _eventlog_message_cache __regkey_hits
+            set regkey [dict get $_eventlog_message_cache $source regkey]
+        } else {
+            set regkey [_find_eventlog_regkey $source]
+            dict set _eventlog_message_cache $source regkey $regkey
+            dict incr _eventlog_message_cache __regkey_misses
+        }
+
+        if {! [catch {registry get $regkey "CategoryMessageFile"} path]} {
+            # Try each file listed in turn
+            foreach dll [split $path \;] {
+                set dll [expand_environment_strings $dll]
+                if {! [catch {
+                    set fmtstring [format_message -module $dll -messageid $category -width $opts(width) -langid $opts(langid)]
+                } msg]} {
+                    dict set _eventlog_message_cache $source category $opts(langid) $category $fmtstring
+                    break
+                }
+            }
+        }
+    }
+
+    if {![info exists fmtstring]} {
+        set fmtstring "Category $category"
+        dict set _eventlog_message_cache $source category $opts(langid) $category $fmtstring
+    }
+
+    return [format_message -fmtstring $fmtstring -params [dict get $rec -params]]
+}
+
+proc twapi::eventlog_monitor_start {hevl script} {
+    variable _eventlog_notification_scripts
+
+    set hevent [lindex [CreateEvent [_make_secattr {} 0] 0 0 ""] 0]
+    if {[catch {NotifyChangeEventLog $hevl $hevent} msg]} {
+        CloseHandle $hevent
+        error $msg $::errorInfo $::errorCode
+    }
+
+    wait_on_handle $hevent -async twapi::_eventlog_notification_handler
+    set _eventlog_notification_scripts($hevent) $script
+
+    # We do not want the application mistakenly closing the event
+    # while being waited on by the thread pool. That would be a big NO-NO
+    # so change the handle type so it cannot be passed to close_handle.
+    return [list evl $hevent]
+}
+
+# Stop any notifications. Note these will stop even if the event log
+# handle is closed but leave the event dangling.
+proc twapi::eventlog_monitor_stop {hevent} {
+    variable _eventlog_notification_scripts
+    set hevent [lindex $hevent 1]
+    if {[info exists _eventlog_notification_scripts($hevent)]} {
+        unset _eventlog_notification_scripts($hevent)
+        cancel_wait_on_handle $hevent
+        CloseHandle $hevent
+    }
+}
+
+proc twapi::_eventlog_notification_handler {hevent event} {
+    variable _eventlog_notification_scripts
+    if {[info exists _eventlog_notification_scripts($hevent)] &&
+        $event eq "signalled"} {
+        uplevel #0 $_eventlog_notification_scripts($hevent) [list [list evl $hevent]]
+    }
+}
+
+# TBD - document
+proc twapi::eventlog_subscribe {source} {
+    set hevl [eventlog_open -source $source]
+    set hevent [lindex [CreateEvent [_make_secattr {} 0] 0 0 ""] 0]
+    if {[catch {NotifyChangeEventLog $hevl $hevent} msg]} {
+        set erinfo $::errorInfo
+        set ercode $::errorCode
+        CloseHandle $hevent
+        error $hsubscribe $erinfo $ercode
+    }
+
+    return [list $hevl $hevent]
+}
+
+# Utility procs
+
+# Find the registry key corresponding the given event log source
+proc twapi::_find_eventlog_regkey {source} {
+    set topkey {HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Eventlog}
+
+    # Set a default list of children to work around an issue in
+    # the Tcl [registry keys] command where a ERROR_MORE_DATA is returned
+    # instead of a retry with a larger buffer.
+    set keys {Application Security System}
+    catch {set keys [registry keys $topkey]}
+    # Get all keys under this key and look for a source under that
+    foreach key $keys {
+        # See above Tcl issue
+        set srckeys {}
+        catch {set srckeys [registry keys "${topkey}\\$key"]}
+        foreach srckey $srckeys {
+            if {[string equal -nocase $srckey $source]} {
+                return "${topkey}\\${key}\\$srckey"
+            }
+        }
+    }
+
+    # Default to Application - TBD
+    return "${topkey}\\Application"
+}
+
+proc twapi::_eventlog_dump {source chan} {
+    set hevl [eventlog_open -source $source]
+    while {[llength [set events [eventlog_read $hevl]]]} {
+        # print out each record
+        foreach eventrec $events {
+            array set event $eventrec
+            set timestamp [clock format $event(-timewritten) -format "%x %X"]
+            set source   $event(-source)
+            set category [twapi::eventlog_format_category $eventrec -width -1]
+            set message  [twapi::eventlog_format_message $eventrec -width -1]
+            puts $chan "$timestamp  $source  $category  $message"
+        }
+    }
+    eventlog_close $hevl
+}
+
+
+
+
+# If we are not being sourced from a executable resource, need to
+# source the remaining support files. In the former case, they are
+# automatically combined into one so the sourcing is not needed.
+if {![info exists twapi::twapi_eventlog_rc_sourced]} {
+    source [file join [file dirname [info script]] evt.tcl]
+    source [file join [file dirname [info script]] winlog.tcl]
+}

src/punk86.vfs/lib/twapi4.7.2/evt.tcl

@@ -0,0 +1,718 @@
+#
+# Copyright (c) 2012-2014, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# Event log handling for Vista and later
+
+namespace eval twapi {
+    variable _evt;              # See _evt_init
+
+    # System event fields in order returned by _evt_decode_event_system_fields
+    twapi::record evt_system_fields  {
+        -providername -providerguid -eventid -qualifiers -level -task
+        -opcode -keywordmask -timecreated -eventrecordid -activityid
+        -relatedactivityid -pid -tid -channel
+        -computer -sid -version
+    }
+
+    proc _evt_init {} {
+        variable _evt
+
+        # Various structures that we maintain / cache for efficiency as they
+        # are commonly used are kept in the _evt array with the following keys:
+
+        # system_render_context_handle - is the handle to a rendering
+        #    context for the system portion of an event
+        set _evt(system_render_context_handle) [evt_render_context_system]
+
+        # user_render_context_handle - is the handle to a rendering
+        #    context for the user data portion of an event
+        set _evt(user_render_context_handle) [evt_render_context_user]
+
+        # render_buffer - is NULL or holds a pointer to the buffer used to
+        #    retrieve values so does not have to be reallocated every time.
+        set _evt(render_buffer) NULL
+
+        # publisher_handles - caches publisher names to their meta information.
+        #    This is a dictionary indexed with nested keys - 
+        #     publisher, session, lcid. TBD - need a mechanism to clear ?
+        set _evt(publisher_handles) [dict create]
+
+        # -levelname - dict of publisher name / level number to level names
+        set _evt(-levelname) {}
+
+        # -taskname - dict of publisher name / task number to task name
+        set _evt(-taskname) {}
+
+        # -opcodename - dict of publisher name / opcode number to opcode name
+        set _evt(-opcodename) {}
+
+        # No-op the proc once init is done
+        proc _evt_init {} {}
+    }
+}
+
+# TBD - document
+proc twapi::evt_local_session {} {
+    return NULL
+}
+
+# TBD - document
+proc twapi::evt_local_session? {hsess} {
+    return [pointer_null? $hsess]
+}
+
+# TBD - document
+proc twapi::evt_open_session {server args} {
+    array set opts [parseargs args {
+        user.arg
+        domain.arg
+        password.arg
+        {authtype.arg 0}
+    } -nulldefault -maxleftover 0]
+
+    if {![string is integer -strict $opts(authtype)]} {
+        set opts(authtype) [dict get {default 0 negotiate 1 kerberos 2 ntlm 3} [string tolower $opts(authtype)]]
+    }
+
+    return [EvtOpenSession 1 [list $server $opts(user) $opts(domain) $opts(password) $opts(authtype)] 0 0]
+}
+
+# TBD - document
+proc twapi::evt_close_session {hsess} {
+    if {![evt_local_session? $hsess]} {
+        evt_close $hsess
+    }
+}
+
+proc twapi::evt_channels {{hevtsess NULL}} {
+    # TBD - document hevtsess
+    set chnames {}
+    set hevt [EvtOpenChannelEnum $hevtsess 0]
+    trap {
+        while {[set chname [EvtNextChannelPath $hevt]] ne ""} {
+            lappend chnames $chname
+        }
+    } finally {
+        evt_close $hevt
+    }
+
+    return $chnames
+}
+
+proc twapi::evt_clear_log {chanpath args} {
+    # TBD - document -session
+    array set opts [parseargs args {
+        {session.arg NULL}
+        {backup.arg ""}
+    } -maxleftover 0]
+
+    return [EvtClearLog $opts(session) $chanpath [_evt_normalize_path $opts(backup)] 0]
+}
+
+# TBD - document
+proc twapi::evt_archive_exported_log {logpath args} {
+    array set opts [parseargs args {
+        {session.arg NULL}
+        {lcid.int 0}
+    } -maxleftover 0]
+
+    return [EvtArchiveExportedLog $opts(session) [_evt_normalize_path $logpath] $opts(lcid) 0]
+}
+
+proc twapi::evt_export_log {outfile args} {
+    # TBD - document -session
+    array set opts [parseargs args {
+        {session.arg NULL}
+        file.arg
+        channel.arg
+        {query.arg *}
+        {ignorequeryerrors 0 0x1000}
+    } -maxleftover 0]
+
+    if {([info exists opts(file)] && [info exists opts(channel)]) ||
+        ! ([info exists opts(file)] || [info exists opts(channel)])} {
+        error "Exactly one of -file or -channel must be specified."
+    }
+
+    if {[info exists opts(file)]} {
+        set path [_evt_normalize_path $opts(file)]
+        incr opts(ignorequeryerrors) 2
+    } else {
+        set path $opts(channel)
+        incr opts(ignorequeryerrors) 1
+    }
+
+    return [EvtExportLog $opts(session) $path $opts(query) [_evt_normalize_path $outfile] $opts(ignorequeryerrors)]
+}
+
+# TBD - document
+proc twapi::evt_create_bookmark {{mark ""}} {
+    return [EvtCreateBookmark $mark]
+}
+
+# TBD - document
+proc twapi::evt_render_context_xpaths {xpaths} {
+    return [EvtCreateRenderContext $xpaths 0]
+}
+
+# TBD - document
+proc twapi::evt_render_context_system {} {
+    return [EvtCreateRenderContext {} 1]
+}
+
+# TBD - document
+proc twapi::evt_render_context_user {} {
+    return [EvtCreateRenderContext {} 2]
+}
+
+# TBD - document
+proc twapi::evt_open_channel_config {chanpath args} {
+    array set opts [parseargs args {
+        {session.arg NULL}
+    } -maxleftover 0]
+
+    return [EvtOpenChannelConfig $opts(session) $chanpath 0]
+}
+
+# TBD - document
+proc twapi::evt_get_channel_config {hevt args} {
+    set result {}
+    foreach opt $args {
+        lappend result $opt \
+            [EvtGetChannelConfigProperty $hevt \
+                 [_evt_map_channel_config_property $hevt $propid]]
+    }
+    return $result
+}
+
+# TBD - document
+proc twapi::evt_set_channel_config {hevt propid val} {
+    return [EvtSetChannelConfigProperty $hevt [_evt_map_channel_config_property $propid 0 $val]]
+}
+
+
+# TBD - document
+proc twapi::_evt_map_channel_config_property {propid} {
+    if {[string is integer -strict $propid]} {
+        return $propid
+    }
+    
+    # Note: values are from winevt.h, Win7 SDK has typos for last few
+    return [dict get {
+        -enabled                  0
+        -isolation                1
+        -type                     2
+        -owningpublisher          3
+        -classiceventlog          4
+        -access                   5
+        -loggingretention         6
+        -loggingautobackup        7
+        -loggingmaxsize           8
+        -logginglogfilepath       9
+        -publishinglevel          10
+        -publishingkeywords       11
+        -publishingcontrolguid    12
+        -publishingbuffersize     13
+        -publishingminbuffers     14
+        -publishingmaxbuffers     15
+        -publishinglatency        16
+        -publishingclocktype      17
+        -publishingsidtype        18
+        -publisherlist            19
+        -publishingfilemax        20
+    } $propid]
+}
+
+# TBD - document
+proc twapi::evt_event_info {hevt args} {
+    set result {}
+    foreach opt $args {
+        lappend result $opt [EvtGetEventInfo $hevt \
+                                 [dict get {-queryids 0 -path 1} $opt]]
+    }
+    return $result
+}
+
+
+# TBD - document
+proc twapi::evt_event_metadata_property {hevt args} {
+    set result {}
+    foreach opt $args {
+        lappend result $opt \
+            [EvtGetEventMetadataProperty $hevt \
+                 [dict get {
+                     -id 0 -version 1 -channel 2 -level 3
+                     -opcode 4 -task 5 -keyword 6 -messageid 7 -template 8
+                 } $opt]]
+    }
+    return $result
+}
+
+
+# TBD - document
+proc twapi::evt_open_log_info {args} {
+    array set opts [parseargs args {
+        {session.arg NULL}
+        file.arg
+        channel.arg
+    } -maxleftover 0]
+
+    if {([info exists opts(file)] && [info exists opts(channel)]) ||
+        ! ([info exists opts(file)] || [info exists opts(channel)])} {
+        error "Exactly one of -file or -channel must be specified."
+    }
+    
+    if {[info exists opts(file)]} {
+        set path [_evt_normalize_path $opts(file)]
+        set flags 0x2
+    } else {
+        set path $opts(channel)
+        set flags 0x1
+    }
+
+    return [EvtOpenLog $opts(session) $path $flags]
+}
+
+# TBD - document
+proc twapi::evt_log_info {hevt args} {
+    set result {}
+    foreach opt $args {
+        lappend result $opt  [EvtGetLogInfo $hevt [dict get {
+            -creationtime 0 -lastaccesstime 1 -lastwritetime 2
+            -filesize 3 -attributes 4 -numberoflogrecords 5
+            -oldestrecordnumber 6 -full 7
+        } $opt]]
+    }
+    return $result
+}
+
+# TBD - document
+proc twapi::evt_publisher_metadata_property {hpub args} {
+    set result {}
+    foreach opt $args {
+        set val [EvtGetPublisherMetadataProperty $hpub [dict get {
+            -publisherguid 0  -resourcefilepath 1 -parameterfilepath 2
+            -messagefilepath 3 -helplink 4 -publishermessageid 5
+            -channelreferences 6 -levels 12 -tasks 16
+            -opcodes 21 -keywords 25
+        } $opt] 0]
+        if {$opt ni {-channelreferences -levels -tasks -opcodes -keywords}} {
+            lappend result $opt $val
+            continue
+        }
+        set n [EvtGetObjectArraySize $val]
+        set val2 {}
+        for {set i 0} {$i < $n} {incr i} {
+            set rec {}
+            foreach {opt2 iopt} [dict get {
+                -channelreferences { -channelreferencepath 7
+                    -channelreferenceindex 8 -channelreferenceid 9
+                    -channelreferenceflags 10 -channelreferencemessageid 11}
+                -levels { -levelname 13 -levelvalue 14 -levelmessageid 15 }
+                -tasks { -taskname 17 -taskeventguid 18 -taskvalue 19
+                    -taskmessageid 20}
+                -opcodes {-opcodename 22 -opcodevalue 23 -opcodemessageid 24}
+                -keywords {-keywordname 26 -keywordvalue 27
+                    -keywordmessageid 28}
+            } $opt] {
+                lappend rec $opt2 [EvtGetObjectArrayProperty $val $iopt $i]
+            }
+            lappend val2 $rec
+        }
+
+        evt_close $val
+        lappend result $opt $val2
+    }
+    return $result
+}
+
+# TBD - document
+proc twapi::evt_query_info {hq args} {
+    set result {}
+    foreach opt $args {
+        lappend result $opt  [EvtGetQueryInfo $hq [dict get {
+            -names 1 statuses 2
+        } $opt]]
+    }
+    return $result
+}
+
+# TBD - document
+proc twapi::evt_object_array_size {hevt} {
+    return [EvtGetObjectArraySize $hevt]
+}
+
+# TBD - document
+proc twapi::evt_object_array_property {hevt index args} {
+    set result {}
+
+    foreach opt $args {
+        lappend result $opt \
+            [EvtGetObjectArrayProperty $hevt [dict get {
+                -channelreferencepath 7
+                -channelreferenceindex 8 -channelreferenceid 9
+                -channelreferenceflags 10 -channelreferencemessageid 11
+                -levelname 13 -levelvalue 14 -levelmessageid 15
+                -taskname 17 -taskeventguid 18 -taskvalue 19
+                -taskmessageid 20 -opcodename 22
+                -opcodevalue 23 -opcodemessageid 24
+                -keywordname 26 -keywordvalue 27 -keywordmessageid 28
+            }] $index]
+    }
+    return $result
+}
+
+proc twapi::evt_publishers {{hsess NULL}} {
+    set pubs {}
+    set hevt [EvtOpenPublisherEnum $hsess 0]
+    trap {
+        while {[set pub [EvtNextPublisherId $hevt]] ne ""} {
+            lappend pubs $pub
+        }
+    } finally {
+        evt_close $hevt
+    }
+
+    return $pubs
+}
+
+# TBD - document
+proc twapi::evt_open_publisher_metadata {pub args} {
+    array set opts [parseargs args {
+        {session.arg NULL}
+        logfile.arg
+        lcid.int
+    } -nulldefault -maxleftover 0]
+
+    return [EvtOpenPublisherMetadata $opts(session) $pub $opts(logfile) $opts(lcid) 0]
+}
+
+# TBD - document
+proc twapi::evt_publisher_events_metadata {hpub args} {
+    set henum [EvtOpenEventMetadataEnum $hpub]
+
+    # It is faster to build a list and then have Tcl shimmer to a dict when
+    # required
+    set meta {}
+    trap {
+        while {[set hmeta [EvtNextEventMetadata $henum 0]] ne ""} {
+            lappend meta [evt_event_metadata_property $hmeta {*}$args]
+            evt_close $hmeta
+        }
+    } finally {
+        evt_close $henum
+    }
+    
+    return $meta
+}
+
+proc twapi::evt_query {args} {
+    array set opts [parseargs args {
+        {session.arg NULL}
+        file.arg
+        channel.arg
+        {query.arg *}
+        {ignorequeryerrors 0 0x1000}
+        {direction.sym forward {forward 0x100 reverse 0x200 backward 0x200}}
+    } -maxleftover 0]
+
+    if {([info exists opts(file)] && [info exists opts(channel)]) ||
+        ! ([info exists opts(file)] || [info exists opts(channel)])} {
+        error "Exactly one of -file or -channel must be specified."
+    }
+    
+    set flags $opts(ignorequeryerrors)
+    incr flags $opts(direction)
+
+    if {[info exists opts(file)]} {
+        set path [_evt_normalize_path $opts(file)]
+        incr flags 0x2
+    } else {
+        set path $opts(channel)
+        incr flags 0x1
+    }
+
+    return [EvtQuery $opts(session) $path $opts(query) $flags]
+}
+
+proc twapi::evt_next {hresultset args} {
+    array set opts [parseargs args {
+        {timeout.int -1}
+        {count.int 1}
+        {status.arg}
+    } -maxleftover 0]
+
+    if {[info exists opts(status)]} {
+        upvar 1 $opts(status) status
+        return [EvtNext $hresultset $opts(count) $opts(timeout) 0 status]
+    } else {
+        return [EvtNext $hresultset $opts(count) $opts(timeout) 0]
+    }
+}
+
+twapi::proc* twapi::_evt_decode_event_system_fields {hevt} {
+    _evt_init
+} {
+    variable _evt
+    set _evt(render_buffer) [Twapi_EvtRenderValues $_evt(system_render_context_handle) $hevt $_evt(render_buffer)]
+    set rec [Twapi_ExtractEVT_RENDER_VALUES $_evt(render_buffer)]
+    return [evt_system_fields set $rec \
+                -providername [atomize [evt_system_fields -providername $rec]] \
+                -providerguid [atomize [evt_system_fields -providerguid $rec]] \
+                -channel [atomize [evt_system_fields -channel $rec]] \
+                -computer [atomize [evt_system_fields -computer $rec]]]
+}
+
+# TBD - document. Returns a list of user data values
+twapi::proc* twapi::evt_decode_event_userdata {hevt} {
+    _evt_init
+} {
+    variable _evt
+    set _evt(render_buffer) [Twapi_EvtRenderValues $_evt(user_render_context_handle) $hevt $_evt(render_buffer)]
+    return [Twapi_ExtractEVT_RENDER_VALUES $_evt(render_buffer)]
+}
+
+twapi::proc* twapi::evt_decode_events {hevts args} {
+    _evt_init
+} {
+    variable _evt
+
+    array set opts [parseargs args {
+        {values.arg NULL}
+        {session.arg NULL}
+        {logfile.arg ""}
+        {lcid.int 0}
+        ignorestring.arg
+        message
+        levelname
+        taskname
+        opcodename
+        keywords
+        xml
+    } -ignoreunknown -hyphenated]
+        
+    # SAME ORDER AS _evt_decode_event_system_fields
+    set decoded_fields [evt_system_fields]
+    set decoded_events {}
+    
+    # ORDER MUST BE SAME AS order in which values are appended below
+    foreach opt {-levelname -taskname -opcodename -keywords -xml -message} {
+        if {$opts($opt)} {
+            lappend decoded_fields $opt
+        }
+    }
+
+    foreach hevt $hevts {
+        set decoded [_evt_decode_event_system_fields $hevt]
+        # Get publisher from hevt
+        set publisher [evt_system_fields -providername $decoded]
+
+        if {! [dict exists $_evt(publisher_handles) $publisher $opts(-session) $opts(-lcid)]} {
+            if {[catch {
+                dict set _evt(publisher_handles) $publisher $opts(-session) $opts(-lcid) [EvtOpenPublisherMetadata $opts(-session) $publisher $opts(-logfile) $opts(-lcid) 0]
+            }]} {
+                # TBD - debug log
+                dict set _evt(publisher_handles) $publisher $opts(-session) $opts(-lcid) NULL
+            }
+        }
+        set hpub [dict get $_evt(publisher_handles) $publisher $opts(-session) $opts(-lcid)]
+
+        # See if cached values are present for -levelname -taskname
+        # and -opcodename. TBD - can -keywords be added to this ?
+        foreach {intopt opt callflag} {-level -levelname 2 -task -taskname 3 -opcode -opcodename 4} {
+            if {$opts($opt)} {
+                set ival [evt_system_fields $intopt $decoded]
+                if {[dict exists $_evt($opt) $publisher $ival]} {
+                    lappend decoded [dict get $_evt($opt) $publisher $ival]
+                } else {
+                    # Not cached. Look it up. Value of 0 -> null so
+                    # just use ignorestring if specified.
+                    if {$ival == 0 && [info exists opts(-ignorestring)]} {
+                        set optval $opts(-ignorestring)
+                    } else {
+                        if {[info exists opts(-ignorestring)]} {
+                            if {[EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag optval]} {
+                                dict set _evt($opt) $publisher $ival $optval
+                            } else {
+                                # Note result not cached if not found since
+                                # ignorestring may be different on every call
+                                set optval $opts(-ignorestring)
+                            }
+                        } else {
+                            # -ignorestring not specified so
+                            # will raise error if not found
+                            set optval [EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag]
+                            dict set _evt($opt) $publisher $ival [atomize $optval]
+                        }
+                    }
+                    lappend decoded $optval
+                }
+            }
+        }
+
+        # Non-cached fields
+        # ORDER MUST BE SAME AS decoded_fields ABOVE
+        foreach {opt callflag} {
+            -keywords 5
+            -xml 9
+        } {
+            if {$opts($opt)} {
+                if {[info exists opts(-ignorestring)]} {
+                    if {! [EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag optval]} {
+                        set optval $opts(-ignorestring)
+                    }
+                } else {
+                    set optval [EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag]
+                }
+                lappend decoded $optval
+            }
+        }
+
+        # We treat -message differently because on failure we want
+        # to extract the user data. -ignorestring is not used for this
+        # unless user data extraction also fails
+        if {$opts(-message)} {
+            if {[EvtFormatMessage $hpub $hevt 0 $opts(-values) 1 message]} {
+                lappend decoded $message
+            } else {
+                # TBD - make sure we have a test for this case.
+                # TBD - log
+                if {[catch {
+                    lappend decoded "Message for event could not be found. Event contained user data: [join [evt_decode_event_userdata $hevt] ,]"
+                } message]} {
+                    if {[info exists opts(-ignorestring)]} {
+                        lappend decoded $opts(-ignorestring)
+                    } else {
+                        error $message
+                    }
+                }
+            }
+        }
+        
+        lappend decoded_events $decoded
+    }
+
+    return [list $decoded_fields $decoded_events]
+}
+
+proc twapi::evt_decode_event {hevt args} {
+    return [recordarray index [evt_decode_events [list $hevt] {*}$args] 0 -format dict]
+}
+
+# TBD - document
+proc twapi::evt_format_publisher_message {hpub msgid args} {
+
+    array set opts [parseargs args {
+        {values.arg NULL}
+    } -maxleftover 0]
+        
+    return [EvtFormatMessage $hpub NULL $msgid $opts(values) 8]
+}
+
+# TBD - document
+# Where is this used?
+proc twapi::evt_free_EVT_VARIANT_ARRAY {p} {
+    evt_free $p
+}
+
+# TBD - document
+# Where is this used?
+proc twapi::evt_free_EVT_RENDER_VALUES {p} {
+    evt_free $p
+}
+
+# TBD - document
+proc twapi::evt_seek {hresults pos args} {
+    array set opts [parseargs args {
+        {origin.arg first {first last current}}
+        bookmark.arg
+        {strict 0 0x10000}
+    } -maxleftover 0]
+
+    if {[info exists opts(bookmark)]} {
+        set flags 4
+    } else {
+        set flags [lsearch -exact {first last current} $opts(origin)]
+        incr flags;             # 1 -> first, 2 -> last, 3 -> current
+        set opts(bookmark) NULL
+    }
+        
+    incr flags $opts(strict)
+
+    EvtSeek $hresults $pos $opts(bookmark) 0 $flags
+}
+
+proc twapi::evt_subscribe {path args} {
+    # TBD - document -session and -bookmark and -strict
+    array set opts [parseargs args {
+        {session.arg NULL}
+        {query.arg *}
+        bookmark.arg
+        includeexisting
+        {ignorequeryerrors 0 0x1000}
+        {strict 0 0x10000}
+    } -maxleftover 0]
+
+    set flags [expr {$opts(ignorequeryerrors) | $opts(strict)}]
+    if {[info exists opts(bookmark)]} {
+        set flags [expr {$flags | 3}]
+        set bookmark $opts(origin)
+    } else {
+        set bookmark NULL
+        if {$opts(includeexisting)} {
+            set flags [expr {$flags | 2}]
+        } else {
+            set flags [expr {$flags | 1}]
+        }
+    }
+
+    set hevent [lindex [CreateEvent [_make_secattr {} 0] 0 0 ""] 0]
+    if {[catch {
+        EvtSubscribe $opts(session) $hevent $path $opts(query) $bookmark $flags
+    } hsubscribe]} {
+        set erinfo $::errorInfo
+        set ercode $::errorCode
+        CloseHandle $hevent
+        error $hsubscribe $erinfo $ercode
+    }
+
+    return [list $hsubscribe $hevent]
+}
+
+proc twapi::_evt_normalize_path {path} {
+    # Do not want to rely on [file normalize] returning "" for ""
+    if {$path eq ""} {
+        return ""
+    } else {
+        return [file nativename [file normalize $path]]
+    }
+}
+
+proc twapi::_evt_dump {args} {
+    array set opts [parseargs args {
+        {outfd.arg stdout}
+        count.int
+    } -ignoreunknown]
+
+    set hq [evt_query {*}$args]
+    trap {
+        while {[llength [set hevts [evt_next $hq]]]} {
+            trap {
+                foreach ev [recordarray getlist [evt_decode_events $hevts -message -ignorestring None.] -format dict] {
+                    if {[info exists opts(count)] &&
+                        [incr opts(count) -1] < 0} {
+                        return
+                    }
+                    puts $opts(outfd) "[dict get $ev -timecreated] [dict get $ev -eventrecordid] [dict get $ev -providername]: [dict get $ev -eventrecordid] [dict get $ev -message]"
+                }
+            } finally {
+                evt_close {*}$hevts
+            }
+        }
+    } finally {
+        evt_close $hq
+    }
+}

src/punk86.vfs/lib/twapi4.7.2/handle.tcl

@@ -0,0 +1,236 @@
+#
+# Copyright (c) 2010, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {
+    # Array maps handles we are waiting on to the ids of the registered waits
+    variable _wait_handle_ids
+    # Array maps id of registered wait to the corresponding callback scripts
+    variable _wait_handle_scripts
+    
+}
+
+proc twapi::cast_handle {h type} {
+    # TBD - should this use pointer_from_address:
+    #    return [pointer_from_address [address_from_pointer $h] $type]
+    return [list [lindex $h 0] $type]
+}
+
+proc twapi::close_handle {h} {
+
+    # Cancel waits on the handle, if any
+    cancel_wait_on_handle $h
+    
+    # Then close it
+    CloseHandle $h
+}
+
+# Close multiple handles. In case of errors, collects them but keeps
+# closing remaining handles and only raises the error at the end.
+proc twapi::close_handles {args} {
+    # The original definition for this was broken in that it would
+    # gracefully accept non list parameters as a list of one. In 3.0
+    # the handle format has changed so this does not happen
+    # naturally. We have to try and decipher whether it is a list
+    # of handles or a single handle.
+
+    foreach arg $args {
+        if {[pointer? $arg]} {
+            # Looks like a single handle
+            if {[catch {close_handle $arg} msg]} {
+                set erinfo $::errorInfo
+                set ercode $::errorCode
+                set ermsg $msg
+            }
+        } else {
+            # Assume a list of handles
+            foreach h $arg {
+                if {[catch {close_handle $h} msg]} {
+                    set erinfo $::errorInfo
+                    set ercode $::errorCode
+                    set ermsg $msg
+                }
+            }
+        }
+    }
+
+    if {[info exists erinfo]} {
+        error $msg $erinfo $ercode
+    }
+}
+
+#
+# Wait on a handle
+proc twapi::wait_on_handle {hwait args} {
+    variable _wait_handle_ids
+    variable _wait_handle_scripts
+
+    # When we are invoked from callback, handle is always typed as HANDLE
+    # so convert it so lookups succeed
+    set h [cast_handle $hwait HANDLE]
+
+    # 0x00000008 ->   # WT_EXECUTEONCEONLY
+    array set opts [parseargs args {
+        {wait.int -1}
+        async.arg
+        {executeonce.bool false 0x00000008}
+    }]
+
+    if {![info exists opts(async)]} {
+        if {[info exists _wait_handle_ids($h)]} {
+            error "Attempt to synchronously wait on handle that is registered for an asynchronous wait."
+        }
+
+        set ret [WaitForSingleObject $h $opts(wait)]
+        if {$ret == 0x80} {
+            return abandoned
+        } elseif {$ret == 0} {
+            return signalled
+        } elseif {$ret == 0x102} {
+            return timeout
+        } else {
+            error "Unexpected value $ret returned from WaitForSingleObject"
+        }
+    }
+
+    # async option specified
+
+    # Do not wait on manual reset events as cpu will spin continuously
+    # queueing events
+    if {[pointer? $hwait HANDLE_MANUALRESETEVENT] &&
+        ! $opts(executeonce)
+    } {
+        error "A handle to a manual reset event cannot be waited on asynchronously unless -executeonce is specified."
+    }
+
+    # If handle already registered, cancel previous registration.
+    if {[info exists _wait_handle_ids($h)]} {
+        cancel_wait_on_handle $h
+    }
+
+
+    set id [Twapi_RegisterWaitOnHandle $h $opts(wait) $opts(executeonce)]
+
+    # Set now that successfully registered
+    set _wait_handle_scripts($id) $opts(async)
+    set _wait_handle_ids($h) $id
+
+    return
+}
+
+#
+# Cancel an async wait on a handle
+proc twapi::cancel_wait_on_handle {h} {
+    variable _wait_handle_ids
+    variable _wait_handle_scripts
+
+    if {[info exists _wait_handle_ids($h)]} {
+        Twapi_UnregisterWaitOnHandle $_wait_handle_ids($h)
+        unset _wait_handle_scripts($_wait_handle_ids($h))
+        unset _wait_handle_ids($h)
+    }
+}
+
+#
+# Called from C when a handle is signalled or times out
+proc twapi::_wait_handler {id h event} {
+    variable _wait_handle_ids
+    variable _wait_handle_scripts
+
+    # We ignore the following stale event cases -
+    #  - _wait_handle_ids($h) does not exist : the wait was canceled while
+    #    and event was queued
+    #  - _wait_handle_ids($h) exists but is different from $id - same
+    #    as prior case, except that a new wait has since been initiated
+    #    on the same handle value (which might have be for a different
+    #    resource
+
+    if {[info exists _wait_handle_ids($h)] &&
+        $_wait_handle_ids($h) == $id} {
+        uplevel #0 [linsert $_wait_handle_scripts($id) end $h $event]
+    }
+
+    return
+}
+
+# Get the handle for a Tcl channel
+proc twapi::get_tcl_channel_handle {chan direction} {
+    set direction [expr {[string equal $direction "write"] ? 1 : 0}]
+    return [Tcl_GetChannelHandle $chan $direction]
+}
+
+# Duplicate a OS handle
+proc twapi::duplicate_handle {h args} {
+    variable my_process_handle
+
+    array set opts [parseargs args {
+        sourcepid.int
+        targetpid.int
+        access.arg
+        inherit
+        closesource
+    } -maxleftover 0]
+
+    # Assume source and target processes are us
+    set source_ph $my_process_handle
+    set target_ph $my_process_handle
+
+    if {[string is wideinteger $h]} {
+        set h [pointer_from_address $h HANDLE]
+    }
+
+    trap {
+        set me [pid]
+        # If source pid specified and is not us, get a handle to the process
+        if {[info exists opts(sourcepid)] && $opts(sourcepid) != $me} {
+            set source_ph [get_process_handle $opts(sourcepid) -access process_dup_handle]
+        }
+
+        # Ditto for target process...
+        if {[info exists opts(targetpid)] && $opts(targetpid) != $me} {
+            set target_ph [get_process_handle $opts(targetpid) -access process_dup_handle]
+        }
+
+        # Do we want to close the original handle (DUPLICATE_CLOSE_SOURCE)
+        set flags [expr {$opts(closesource) ? 0x1: 0}]
+
+        if {[info exists opts(access)]} {
+            set access [_access_rights_to_mask $opts(access)]
+        } else {
+            # If no desired access is indicated, we want the same access as
+            # the original handle
+            set access 0
+            set flags [expr {$flags | 0x2}]; # DUPLICATE_SAME_ACCESS
+        }
+
+
+        set dup [DuplicateHandle $source_ph $h $target_ph $access $opts(inherit) $flags]
+
+        # IF targetpid specified, return handle else literal
+        # (even if targetpid is us)
+        if {[info exists opts(targetpid)]} {
+            set dup [pointer_to_address $dup]
+        }
+    } finally {
+        if {$source_ph != $my_process_handle} {
+            CloseHandle $source_ph
+        }
+        if {$target_ph != $my_process_handle} {
+            CloseHandle $source_ph
+        }
+    }
+
+    return $dup
+}
+
+proc twapi::set_handle_inheritance {h inherit} {
+    # 1 -> HANDLE_FLAG_INHERIT
+    SetHandleInformation $h 0x1 [expr {$inherit ? 1 : 0}]
+}
+
+proc twapi::get_handle_inheritance {h} {
+    # 1 -> HANDLE_FLAG_INHERIT
+    return [expr {[GetHandleInformation $h] & 1}]
+}

src/punk86.vfs/lib/twapi4.7.2/input.tcl

@@ -0,0 +1,623 @@
+#
+# Copyright (c) 2012 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+package require twapi_ui;       # SetCursorPos etc.
+
+# Enable window input
+proc twapi::enable_window_input {hwin} {
+    return [expr {[EnableWindow $hwin 1] != 0}]
+}
+
+# Disable window input
+proc twapi::disable_window_input {hwin} {
+    return [expr {[EnableWindow $hwin 0] != 0}]
+}
+
+# CHeck if window input is enabled
+proc twapi::window_input_enabled {hwin} {
+    return [IsWindowEnabled $hwin]
+}
+
+# Simulate user input
+proc twapi::send_input {inputlist} {
+    array set input_defs {
+        MOUSEEVENTF_MOVE        0x0001
+        MOUSEEVENTF_LEFTDOWN    0x0002
+        MOUSEEVENTF_LEFTUP      0x0004
+        MOUSEEVENTF_RIGHTDOWN   0x0008
+        MOUSEEVENTF_RIGHTUP     0x0010
+        MOUSEEVENTF_MIDDLEDOWN  0x0020
+        MOUSEEVENTF_MIDDLEUP    0x0040
+        MOUSEEVENTF_XDOWN       0x0080
+        MOUSEEVENTF_XUP         0x0100
+        MOUSEEVENTF_WHEEL       0x0800
+        MOUSEEVENTF_VIRTUALDESK 0x4000
+        MOUSEEVENTF_ABSOLUTE    0x8000
+        
+        KEYEVENTF_EXTENDEDKEY 0x0001
+        KEYEVENTF_KEYUP       0x0002
+        KEYEVENTF_UNICODE     0x0004
+        KEYEVENTF_SCANCODE    0x0008
+
+        XBUTTON1      0x0001
+        XBUTTON2      0x0002
+    }
+
+    set inputs [list ]
+    foreach input $inputlist {
+        if {[string equal [lindex $input 0] "mouse"]} {
+            lassign $input mouse xpos ypos
+            set mouseopts [lrange $input 3 end]
+            array unset opts
+            array set opts [parseargs mouseopts {
+                relative moved
+                ldown lup rdown rup mdown mup x1down x1up x2down x2up
+                wheel.int
+            }]
+            set flags 0
+            if {! $opts(relative)} {
+                set flags $input_defs(MOUSEEVENTF_ABSOLUTE)
+            }
+
+            if {[info exists opts(wheel)]} {
+                if {($opts(x1down) || $opts(x1up) || $opts(x2down) || $opts(x2up))} {
+                    error "The -wheel input event attribute may not be specified with -x1up, -x1down, -x2up or -x2down events"
+                }
+                set mousedata $opts(wheel)
+                set flags $input_defs(MOUSEEVENTF_WHEEL)
+            } else {
+                if {$opts(x1down) || $opts(x1up)} {
+                    if {$opts(x2down) || $opts(x2up)} {
+                        error "The -x1down, -x1up mouse input attributes are mutually exclusive with -x2down, -x2up attributes"
+                    }
+                    set mousedata $input_defs(XBUTTON1)
+                } else {
+                    if {$opts(x2down) || $opts(x2up)} {
+                        set mousedata $input_defs(XBUTTON2)
+                    } else {
+                        set mousedata 0
+                    }
+                }
+            }
+            foreach {opt flag} {
+                moved MOVE
+                ldown LEFTDOWN
+                lup   LEFTUP
+                rdown RIGHTDOWN
+                rup   RIGHTUP
+                mdown MIDDLEDOWN
+                mup   MIDDLEUP
+                x1down XDOWN
+                x1up   XUP
+                x2down XDOWN
+                x2up   XUP
+            } {
+                if {$opts($opt)} {
+                    set flags [expr {$flags | $input_defs(MOUSEEVENTF_$flag)}]
+                }
+            }
+
+            lappend inputs [list mouse $xpos $ypos $mousedata $flags]
+
+        } else {
+            lassign $input inputtype vk scan keyopts
+            if {"-extended" ni $keyopts} {
+                set extended 0
+            } else {
+                set extended $input_defs(KEYEVENTF_EXTENDEDKEY)
+            }
+            if {"-usescan" ni $keyopts} {
+                set usescan 0
+            } else {
+                set usescan $input_defs(KEYEVENTF_SCANCODE)
+            }
+            switch -exact -- $inputtype {
+                keydown {
+                    lappend inputs [list key $vk $scan [expr {$extended|$usescan}]]
+                }
+                keyup {
+                    lappend inputs [list key $vk $scan \
+                                        [expr {$extended
+                                               | $usescan
+                                               | $input_defs(KEYEVENTF_KEYUP)
+                                           }]]
+                }
+                key {
+                    lappend inputs [list key $vk $scan [expr {$extended|$usescan}]]
+                    lappend inputs [list key $vk $scan \
+                                        [expr {$extended
+                                               | $usescan
+                                               | $input_defs(KEYEVENTF_KEYUP)
+                                           }]]
+                }
+                unicode {
+                    lappend inputs [list key 0 $scan $input_defs(KEYEVENTF_UNICODE)]
+                    lappend inputs [list key 0 $scan \
+                                        [expr {$input_defs(KEYEVENTF_UNICODE)
+                                               | $input_defs(KEYEVENTF_KEYUP)
+                                           }]]
+                }
+                default {
+                    error "Unknown input type '$inputtype'"
+                }
+            }
+        }
+    }
+
+    SendInput $inputs
+}
+
+# Block the input
+proc twapi::block_input {} {
+    return [BlockInput 1]
+}
+
+# Unblock the input
+proc twapi::unblock_input {} {
+    return [BlockInput 0]
+}
+
+# Send the given set of characters to the input queue
+proc twapi::send_input_text {s} {
+    return [Twapi_SendUnicode $s]
+}
+
+# send_keys - uses same syntax as VB SendKeys function
+proc twapi::send_keys {keys} {
+    set inputs [_parse_send_keys $keys]
+    send_input $inputs
+}
+
+
+# Handles a hotkey notification
+proc twapi::_hotkey_handler {msg atom key msgpos ticks} {
+    variable _hotkeys
+
+    # Note it is not an error if a hotkey does not exist since it could
+    # have been deregistered in the time between hotkey input and receiving it.
+    set code 0
+    if {[info exists _hotkeys($atom)]} {
+        foreach handler $_hotkeys($atom) {
+            set code [catch {uplevel #0 $handler} msg]
+            switch -exact -- $code {
+                0 {
+                    # Normal, keep going
+                }
+                1 {
+                    # Error - put in background and abort
+                    after 0 [list error $msg $::errorInfo $::errorCode]
+                    break
+                }
+                3 {
+                    break;      # Ignore remaining handlers
+                }
+                default {
+                    # Keep going
+                }
+            }
+        }
+    }
+    return -code $code ""
+}
+
+proc twapi::register_hotkey {hotkey script args} {
+    variable _hotkeys
+
+    # 0x312 -> WM_HOTKEY
+    _register_script_wm_handler 0x312 [list [namespace current]::_hotkey_handler] 1
+
+    array set opts [parseargs args {
+        append
+    } -maxleftover 0]
+
+#    set script [lrange $script 0 end]; # Ensure a valid list
+
+    lassign  [_hotkeysyms_to_vk $hotkey]  modifiers vk
+    set hkid "twapi_hk_${vk}_$modifiers"
+    set atom [GlobalAddAtom $hkid]
+    if {[info exists _hotkeys($atom)]} {
+        GlobalDeleteAtom $atom; # Undo above AddAtom since already there
+        if {$opts(append)} {
+            lappend _hotkeys($atom) $script
+        } else {
+            set _hotkeys($atom) [list $script]; # Replace previous script
+        }
+        return $atom
+    }
+    trap {
+        RegisterHotKey $atom $modifiers $vk
+    } onerror {} {
+        GlobalDeleteAtom $atom; # Undo above AddAtom
+        rethrow
+    }
+    set _hotkeys($atom) [list $script]; # Replace previous script
+    return $atom
+}
+
+proc twapi::unregister_hotkey {atom} {
+    variable _hotkeys
+    if {[info exists _hotkeys($atom)]} {
+        UnregisterHotKey $atom
+        GlobalDeleteAtom $atom
+        unset _hotkeys($atom)
+    }
+}
+
+
+# Simulate clicking a mouse button
+proc twapi::click_mouse_button {button} {
+    switch -exact -- $button {
+        1 -
+        left { set down -ldown ; set up -lup}
+        2 -
+        right { set down -rdown ; set up -rup}
+        3 -
+        middle { set down -mdown ; set up -mup}
+        x1     { set down -x1down ; set up -x1up}
+        x2     { set down -x2down ; set up -x2up}
+        default {error "Invalid mouse button '$button' specified"}
+    }
+
+    send_input [list \
+                    [list mouse 0 0 $down] \
+                    [list mouse 0 0 $up]]
+    return
+}
+
+# Simulate mouse movement
+proc twapi::move_mouse {xpos ypos {mode ""}} {
+    # If mouse trails are enabled, it leaves traces when the mouse is
+    # moved and does not clear them until mouse is moved again. So
+    # we temporarily disable mouse trails if we can
+
+    if {[llength [info commands ::twapi::get_system_parameters_info]] != 0} {
+        set trail [get_system_parameters_info SPI_GETMOUSETRAILS]
+        set_system_parameters_info SPI_SETMOUSETRAILS 0
+    }
+    switch -exact -- $mode {
+        -relative {
+            lappend cmd -relative
+            lassign [GetCursorPos] curx cury
+            incr xpos $curx
+            incr ypos $cury
+        }
+        -absolute -
+        ""        { }
+        default   { error "Invalid mouse movement mode '$mode'" }
+    }
+
+    SetCursorPos $xpos $ypos
+
+    # Restore trail setting if we had disabled it and it was originally enabled
+    if {[info exists trail] && $trail} {
+        set_system_parameters_info SPI_SETMOUSETRAILS $trail
+    }
+}
+
+# Simulate turning of the mouse wheel
+proc twapi::turn_mouse_wheel {wheelunits} {
+    send_input [list [list mouse 0 0 -relative -wheel $wheelunits]]
+    return
+}
+
+# Get the mouse/cursor position
+proc twapi::get_mouse_location {} {
+    return [GetCursorPos]
+}
+
+proc twapi::get_input_idle_time {} {
+    # The formats are to convert wrapped 32bit signed to unsigned
+    set last_event [format 0x%x [GetLastInputInfo]]
+    set now [format 0x%x [GetTickCount]]
+
+    # Deal with wrap around
+    if {$now >= $last_event} {
+        return [expr {$now - $last_event}]
+    } else {
+        return [expr {$now + (0xffffffff - $last_event) + 1}]
+    }
+}
+
+# Initialize the virtual key table
+proc twapi::_init_vk_map {} {
+    variable vk_map
+
+    if {![info exists vk_map]} {
+        # Map tokens to VK_* key codes
+        array set vk_map {
+            BACK {0x08 0}
+            BACKSPACE {0x08 0}   BS {0x08 0}   BKSP {0x08 0}   TAB {0x09 0}
+            CLEAR {0x0C 0}   RETURN {0x0D 0}   ENTER {0x0D 0}   SHIFT {0x10 0}
+            CONTROL {0x11 0}   MENU {0x12 0}   ALT {0x12 0}   PAUSE {0x13 0}
+            BREAK {0x13 0}   CAPITAL {0x14 0}   CAPSLOCK {0x14 0}
+            KANA {0x15 0}   HANGEUL {0x15 0}   HANGUL {0x15 0}   JUNJA {0x17 0}
+            FINAL {0x18 0}   HANJA {0x19 0}   KANJI {0x19 0}   ESCAPE {0x1B 0}
+            ESC {0x1B 0}   CONVERT {0x1C 0}   NONCONVERT {0x1D 0}
+            ACCEPT {0x1E 0}   MODECHANGE {0x1F 0}   SPACE {0x20 0}
+            PRIOR {0x21 0}   PGUP {0x21 0}   NEXT {0x22 0}   PGDN {0x22 0}
+            END {0x23 0}   HOME {0x24 0}   LEFT {0x25 0}   UP {0x26 0}
+            RIGHT {0x27 0}   DOWN {0x28 0}   SELECT {0x29 0}
+            PRINT {0x2A 0}   PRTSC {0x2C 0}   EXECUTE {0x2B 0}
+            SNAPSHOT {0x2C 0}   INSERT {0x2D 0}   INS {0x2D 0}
+            DELETE {0x2E 0}   DEL {0x2E 0}   HELP {0x2F 0}   LWIN {0x5B 0}
+            RWIN {0x5C 0}   APPS {0x5D 0}   SLEEP {0x5F 0}   NUMPAD0 {0x60 0}
+            NUMPAD1 {0x61 0}   NUMPAD2 {0x62 0}   NUMPAD3 {0x63 0}
+            NUMPAD4 {0x64 0}   NUMPAD5 {0x65 0}   NUMPAD6 {0x66 0}
+            NUMPAD7 {0x67 0}   NUMPAD8 {0x68 0}   NUMPAD9 {0x69 0}
+            MULTIPLY {0x6A 0}   ADD {0x6B 0}   SEPARATOR {0x6C 0}
+            SUBTRACT {0x6D 0}   DECIMAL {0x6E 0}   DIVIDE {0x6F 0}
+            F1 {0x70 0}   F2 {0x71 0}   F3 {0x72 0}   F4 {0x73 0}
+            F5 {0x74 0}   F6 {0x75 0}   F7 {0x76 0}   F8 {0x77 0}
+            F9 {0x78 0}   F10 {0x79 0}   F11 {0x7A 0}   F12 {0x7B 0}
+            F13 {0x7C 0}   F14 {0x7D 0}   F15 {0x7E 0}   F16 {0x7F 0}
+            F17 {0x80 0}   F18 {0x81 0}   F19 {0x82 0}   F20 {0x83 0}
+            F21 {0x84 0}   F22 {0x85 0}   F23 {0x86 0}   F24 {0x87 0}
+            NUMLOCK {0x90 0}   SCROLL {0x91 0}   SCROLLLOCK {0x91 0}
+            LSHIFT {0xA0 0}   RSHIFT {0xA1 0 -extended}   LCONTROL {0xA2 0}
+            RCONTROL {0xA3 0 -extended}   LMENU {0xA4 0}   LALT {0xA4 0}
+            RMENU {0xA5 0 -extended}   RALT {0xA5 0 -extended}
+            BROWSER_BACK {0xA6 0}   BROWSER_FORWARD {0xA7 0}
+            BROWSER_REFRESH {0xA8 0}   BROWSER_STOP {0xA9 0}
+            BROWSER_SEARCH {0xAA 0}   BROWSER_FAVORITES {0xAB 0}
+            BROWSER_HOME {0xAC 0}   VOLUME_MUTE {0xAD 0}
+            VOLUME_DOWN {0xAE 0}   VOLUME_UP {0xAF 0}
+            MEDIA_NEXT_TRACK {0xB0 0}   MEDIA_PREV_TRACK {0xB1 0}
+            MEDIA_STOP {0xB2 0}   MEDIA_PLAY_PAUSE {0xB3 0}
+            LAUNCH_MAIL {0xB4 0}   LAUNCH_MEDIA_SELECT {0xB5 0}
+            LAUNCH_APP1 {0xB6 0}   LAUNCH_APP2 {0xB7 0}
+        }
+    }
+}
+
+# Find the next token from a send_keys argument
+# Returns pair token,position after token
+proc twapi::_parse_send_key_token {keys start} {
+    set char [string index $keys $start]
+    if {$char ne "\{"} {
+        return [list $char [incr start]]
+    }
+    # Need to find the matching end brace. Note special case of
+    # start/end brace enclosed within braces
+    set n [string length $keys]
+    # Jump past brace and succeeding character (which may be end brace)
+    set terminator [string first "\}" $keys $start+2]
+    if {$terminator < 0} {
+        error "Unterminated or empty braced key token."
+    }
+    return [list [string range $keys $start $terminator] [incr terminator]]
+}
+
+# Appends to inputs the trailer in reverse order. trailer is reset
+proc twapi::_flush_send_keys_trailer {vinputs vtrailer} {
+    upvar 1 $vinputs inputs
+    upvar 1 $vtrailer trailer
+
+    lappend inputs {*}[lreverse $trailer]
+    set trailer {}
+}
+
+# Constructs a list of input events by parsing a string in the format
+# used by Visual Basic's SendKeys function. See that documentation
+# for syntax.
+proc twapi::_parse_send_keys {keys} {
+    variable vk_map
+
+    _init_vk_map
+    array set modifier_vk {+ 0x10 ^ 0x11 % 0x12}
+
+    # Array state holds state of the parse. An atom refers to a single
+    # character or a () group.
+    #  modifiers - list of current modifiers in order they were added including
+    #     those coming from containing groups.
+    #  group_modifiers - stack of modifiers state when parsing groups.
+    #     When a group begins, state(modifiers) is pushed on this stack.
+    #     The top of the stack is used to initialize state(modifiers)
+    #     for every atom within the group. When the group ends,
+    #     the top of the stack is popped and discarded and state(modifiers)
+    #     is reinitialized to new top of stack.
+    #  trailer - list of trailing input records to add after next atom. Note
+    #    these are stored in order of occurence but need to be reversed
+    #    when emitted
+    #  group_trailers - stack of trailers to add after group ends. Each
+    #    element is a trailer which is a list of input records.
+    #  cleanup_trailer - to be emitted right at the end if we have to
+    #    reset CAPSLOCK/NUMLOCK/SCROLL
+    set state(modifiers) {}
+    set state(group_modifiers) [list $state(modifiers)]; # "Global" group
+    set state(trailer) {}
+    set state(group_trailers) {}
+    set state(cleanup_trailer) {}
+
+    set inputs {}
+
+    # If {CAPS,NUM,SCROLL}LOCK are set, need to reset them and then
+    # set them back
+    foreach vk {20 144 145} {
+        if {[GetKeyState $vk]} {
+            lappend inputs [list key $vk 0]
+            lappend state(cleanup_trailer) [list key $vk 0]
+        }
+    }
+
+    set keyslen [string length $keys]
+    set pos 0;                  # Current parse position
+    while {$pos < $keyslen} {
+        lassign [_parse_send_key_token $keys $pos] token pos
+        switch -exact -- $token {
+            + -
+            ^ -
+            % {
+                if {$token in $state(modifiers)} {
+                    # Following VB SendKeys
+                    error "Modifier state for $token already set."
+                }
+                lappend state(modifiers) $token
+                lappend inputs [list keydown $modifier_vk($token) 0]
+                lappend state(trailer) [list keyup $modifier_vk($token) 0]
+            }
+            "(" {
+                # Start a group
+                lappend state(group_modifiers) $state(modifiers)
+                lappend state(group_trailers) $state(trailer)
+                set state(trailer) {}
+            }
+            ")" {
+                # Terminates group. Illegal if no group collection in progress
+                if {[llength $state(group_trailers)] == 0} {
+                    error "Unmatched \")\" in send_keys string."
+                }
+                # If there is a live trailer inside group, emit it e.g. +(ab^)
+                _flush_send_keys_trailer inputs state(trailer)
+                # Now emit the group trailer
+                set trailer [lpop state(group_trailers)]
+                _flush_send_keys_trailer inputs trailer
+                # Discard the initial modifier state for this group
+                lpop state(group_modifiers)
+                # Set the current modifiers to outer group state
+                set state(modifiers) [lindex $state(group_modifiers) end]
+            }
+            default {
+                if {$token eq "~"} {
+                    set token "{ENTER}"
+                }
+                # May be a single character to send, a braced virtual key
+                # or a braced single char with count
+                if {[string length $token] == 1} {
+                    # Single character.
+                    set key $token
+                    set nch 1
+                } elseif {[string index $token 0] eq "\{"} {
+                    # NOTE: a ~ inside a brace is treated as a literal ~
+                    # and not the ENTER key
+                    # Look for space skipping the starting brace and following
+                    # character which may be itself a space (to be repeated)
+                    set space_pos [string first " " $token 2]
+                    if {$space_pos < 0} {
+                        # No space found
+                        set nch 1
+                        set key [string range $token 1 end-1]
+                    } else {
+                        # A key followed by a count
+                        # Note space_pos >= 2
+                        set key [string range $token 1 $space_pos-1]
+                        set nch [string trim [string range $token $space_pos+1 end-1]]
+                        if {![string is integer -strict $nch] || $nch < 0} {
+                            error "Invalid count \"$nch\" in send_keys."
+                        } 
+                    }
+                } else {
+                    # Problem in token parsing. Would be a bug.
+                    error "Internal error: invalid token \"$token\" parsing send_keys string."
+                }
+
+                set vk_leader  {}
+                set vk_trailer {}
+                if {[string length $key] == 1} {
+                    # Single character
+                    lassign [VkKeyScan $key] modifiers vk
+                    if {$modifiers == -1 || $vk == -1} {
+                        scan $key %c code_point
+                        set vk_rec [list unicode 0 $code_point]
+                    } else {
+                        # Generates input records for modifiers that are set
+                        # unless they are already set. NOTE: Do NOT set the
+                        # state(modifier) state since they will be in effect
+                        # only for the current character. This is for correctly
+                        # showing A-Z with shift and Ctrl-A etc. with control.
+                        if {($modifiers & 0x1) && ("+" ni $state(modifiers))} {
+                            lappend vk_leader  [list keydown 0x10 0]
+                            lappend vk_trailer [list keyup 0x10 0]
+                        }
+                        if {($modifiers & 0x2) && ("^" ni $state(modifiers))} {
+                            lappend vk_leader  [list keydown 0x11 0]
+                            lappend vk_trailer [list keyup 0x11 0]
+                        }
+
+                        if {($modifiers & 0x4) && ("%" ni $state(modifiers))} {
+                            lappend vk_leader  [list keydown 0x12 0]
+                            lappend vk_trailer [list keyup 0x12 0]
+                        }
+                        set vk_rec [list key $vk 0]
+                    }
+                } else {
+                    # Virtual key string. Note modifiers ignored here
+                    # as for VB SendKeys
+                    if {[info exists vk_map($key)]} {
+                        # Virtual key
+                        set vk_rec [list key {*}$vk_map($key)]
+                    } else {
+                        error "Unknown braced virtual key \"$token\"."
+                    }
+                }
+                lappend inputs {*}$vk_leader
+                lappend inputs {*}[lrepeat $nch $vk_rec]
+                # vk_trailer arises from the character itself, e.g. A
+                # has shift set, Ctrl-A has control set.
+                _flush_send_keys_trailer inputs vk_trailer
+                # state(trailer) arises from preceding +,^,% This is also
+                # emitted and reset as it applied only to this character
+                _flush_send_keys_trailer inputs state(trailer)
+                set state(modifiers) [lindex $state(group_modifiers) end]
+            }
+        }
+    }
+    # Emit left over trailer
+    _flush_send_keys_trailer inputs state(trailer)
+
+    # Restore capslock/numlock
+    _flush_send_keys_trailer inputs state(cleanup_trailer)
+
+    return $inputs
+}
+
+# utility procedure to map symbolic hotkey to {modifiers virtualkey}
+# We allow modifier map to be passed in because different api's use
+# different bits for key modifiers
+proc twapi::_hotkeysyms_to_vk {hotkey {modifier_map {ctrl 2 control 2 alt 1 menu 1 shift 4 win 8}}} {
+    variable vk_map
+
+    _init_vk_map
+
+    set keyseq [split [string tolower $hotkey] -]
+    set key [lindex $keyseq end]
+
+    # Convert modifiers to bitmask
+    set modifiers 0
+    foreach modifier [lrange $keyseq 0 end-1] {
+        setbits modifiers [dict! $modifier_map [string tolower $modifier]]
+    }
+    # Map the key to a virtual key code
+    if {[string length $key] == 1} {
+        # Single character
+        scan $key %c unicode
+
+        # Only allow alphanumeric keys and a few punctuation symbols
+        # since keyboard layouts are not standard
+        if {$unicode >= 0x61 && $unicode <= 0x7A} {
+            # Lowercase letters - change to upper case virtual keys
+            set vk [expr {$unicode-32}]
+        } elseif {($unicode >= 0x30 && $unicode <= 0x39)
+                  || ($unicode >= 0x41 && $unicode <= 0x5A)} {
+            # Digits or upper case
+            set vk $unicode
+        } else {
+            error "Only alphanumeric characters may be specified for the key. For non-alphanumeric characters, specify the virtual key code"
+        }
+    } elseif {[info exists vk_map($key)]} {
+        # It is a virtual key name
+        set vk [lindex $vk_map($key) 0]
+    } elseif {[info exists vk_map([string toupper $key])]} {
+        # It is a virtual key name
+        set vk [lindex $vk_map([string toupper $key]) 0]
+    } elseif {[string is integer -strict $key]} {
+        # Actual virtual key specification
+        set vk $key
+    } else {
+        error "Unknown or invalid key specifier '$key'"
+    }
+
+    return [list $modifiers $vk]
+}

src/punk86.vfs/lib/twapi4.7.2/metoo.tcl

@@ -0,0 +1,605 @@
+# MeTOO stands for "MeTOO Emulates TclOO" (at a superficial syntactic level)
+#
+# Implements a *tiny*, but useful, subset of TclOO, primarily for use 
+# with Tcl 8.4. Intent is that if you write code using MeToo, it should work 
+# unmodified with TclOO in 8.5/8.6. Obviously, don't try going the other way!
+#
+# Emulation is superficial, don't try to be too clever in usage.
+# Doing funky, or even non-funky, things with object namespaces will
+# not work as you would expect.
+#
+# See the metoo::demo proc for sample usage. Calling this proc
+# with parameter "oo" will use the TclOO commands. Else the metoo::
+# commands. Note the demo code remains the same for both.
+#
+# The following fragment uses MeToo only if TclOO is not available:
+#   if {[llength [info commands oo::*]]} {
+#       namespace import oo::*
+#   } else {
+#       source metoo.tcl
+#       namespace import metoo::class
+#   }
+#   class create C {...}
+#
+# Summary of the TclOO subset implemented - see TclOO docs for detail :
+#
+# Creating a new class: 
+#   metoo::class create CLASSNAME CLASSDEFINITION
+#
+# Destroying a class:
+#   CLASSNAME destroy
+#    - this also destroys objects of that class and recursively destroys
+#      child classes. NOTE: deleting the class namespace or renaming 
+#      the CLASSNAME command to "" will NOT call object destructors.
+#
+# CLASSDEFINITION: Following may appear in CLASSDEFINTION
+#   method METHODNAME params METHODBODY
+#    - same as TclOO
+#   constructor params METHODBODY
+#    - same syntax as TclOO
+#   destructor METHODBODY
+#    - same syntax as TclOO
+#   unknown METHODNAME ARGS
+#    - if defined, called when an undefined method is invoked
+#   superclass SUPER
+#    - inherits from SUPER. Unlike TclOO, only single inheritance. Also
+#      no checks for inheritance loops. You'll find out quickly enough!
+#   All other commands within a CLASSDEFINITION will either raise error or
+#   work differently from TclOO. Actually you can use pretty much any
+#   Tcl command inside CLASSDEFINITION but the results may not be what you
+#   expect. Best to avoid this.
+#
+# METHODBODY: The following method-internal TclOO commands are available:
+#   my METHODNAME ARGS
+#    - to call another method METHODNAME
+#   my variable VAR1 ?VAR2...?
+#    - brings object-specific variables into scope
+#   next ?ARGS?
+#    - calls the superclass method of the same name
+#   self
+#   self object
+#    - returns the object name (usable as a command)
+#   self class
+#    - returns class of this object
+#   self namespace
+#    - returns namespace of this object
+#
+# Creating objects:
+#   CLASSNAME create OBJNAME ?ARGS?
+#    - creates object OBJNAME of class CLASSNAME, passing ARGS to constructor
+#      Returns the fully qualified object name that can be used as a command.
+#   CLASSNAME new ?ARGS?
+#    - creates a new object with an auto-generated name
+#
+# Destroying objects
+#   OBJNAME destroy
+#    - destroys the object calling destructors
+#   rename OBJNAME ""
+#    - same as above
+#
+# Renaming an object
+#   rename OBJNAME NEWNAME
+#    - the object can now be invoked using the new name. Note this is unlike
+#      classes which should not be renamed.
+#
+#
+# Introspection (though different from TclOO)
+#   metoo::introspect object isa OBJECT ?CLASSNAME?
+#    - returns 1 if OBJECT is a metoo object and is of the specified class
+#      if CLASSNAME is specified. Returns 0 otherwise.
+#   metoo::introspect object list
+#    - returns list of all objects
+#   metoo::introspect class ancestors CLASSNAME
+#    - returns list of ancestors for a class
+#
+# Differences and missing features from TclOO: Everything not listed above
+# is missing. Some notable differences:
+# - MeTOO is class-based, not object based like TclOO, thus class instances
+#   (objects) cannot be modified by adding instance-specific methods etc..
+#   Also a class is not itself an object.
+# - Renaming classes does not work and will fail in mysterious ways
+# - does not support class refinement/definition
+# - no variable command at class level for automatically bringing variables
+#   into scope
+# - no filters, forwarding, multiple-inheritance
+# - no private methods (all methods are exported).
+
+# NOTE: file must be sourced at global level since metoo namespace is expected
+# to be top level namespace
+
+# DO NOT DO THIS. ELSE TESTS FAIL BECAUSE they define tests in the
+# metoo namespace which then get deleted by the line below when
+# the package is lazy auto-loaded
+# catch {namespace delete metoo}
+
+# TBD - variable ("my variable" is done, "variable" in method or
+# class definition is not)
+# TBD - default constructor and destructor to "next" (or maybe that
+# is already taken care of by the inheritance code
+
+namespace eval metoo {
+    variable next_id 0
+
+    variable _objects;          # Maps objects to its namespace
+    array set _objects {}
+    
+}
+
+# Namespace in which commands in a class definition block are called
+namespace eval metoo::define {
+    proc method {class_ns name params body} {
+        # Methods are defined in the methods subspace of the class namespace.
+        # We prefix with _m_ to prevent them from being directly called
+        # as procs, for example if the method is a Tcl command like "set"
+        # The first parameter to a method is always the object namespace
+        # denoted as the paramter "_this"
+        namespace eval ${class_ns}::methods [list proc _m_$name [concat [list _this] $params] $body]
+
+    }
+    proc superclass {class_ns superclass} {
+        if {[info exists ${class_ns}::super]} {
+            error "Only one superclass allowed for a class"
+        }
+        set sup [uplevel 3 "namespace eval $superclass {namespace current}"]
+        set ${class_ns}::super $sup
+        # We store the subclass in the super so it can be destroyed
+        # if the super is destroyed.
+        set ${sup}::subclasses($class_ns) 1
+    }
+    proc constructor {class_ns params body} {
+        method $class_ns constructor $params $body
+    }
+    proc destructor {class_ns body} {
+        method $class_ns destructor {} $body
+    }
+    proc export {args} {
+        # Nothing to do, all methods are exported anyways
+        # Command is here for compatibility only
+    }
+}
+
+# Namespace in which commands used in objects methods are defined
+# (self, my etc.)
+namespace eval metoo::object {
+    proc next {args} {
+        upvar 1 _this this;     # object namespace
+
+        # Figure out what class context this is executing in. Note
+        # we cannot use _this in caller since that is the object namespace
+        # which is not necessarily related to the current class namespace.
+        set class_ns [namespace parent [uplevel 1 {namespace current}]]
+        
+        # Figure out the current method being called
+        set methodname [namespace tail [lindex [uplevel 1 {info level 0}] 0]]
+        
+        # Find the next method in the class hierarchy and call it
+        while {[info exists ${class_ns}::super]} {
+            set class_ns [set ${class_ns}::super]
+            if {[llength [info commands ${class_ns}::methods::$methodname]]} {
+                return [uplevel 1 [list ${class_ns}::methods::$methodname $this] $args]
+            }
+        }
+        
+        error "'next' command has no receiver in the hierarchy for method $methodname"
+    }
+
+    proc self {{what object}} {
+        upvar 1 _this this
+        switch -exact -- $what {
+            class { return [namespace parent $this] }
+            namespace { return $this }
+            object { return [set ${this}::_(name)] }
+            default {
+                error "Argument '$what' not understood by self method"
+            }
+        }
+    }
+
+    proc my {methodname args} {
+        # We insert the object namespace as the first parameter to the command.
+        # This is passed as the first parameter "_this" to methods. Since
+        # "my" can be only called from methods, we can retrieve it fro
+        # our caller.
+        upvar 1 _this this;     # object namespace
+
+        set class_ns [namespace parent $this]
+
+        set meth [::metoo::_locate_method $class_ns $methodname]
+        if {$meth ne ""} {
+            # We need to invoke in the caller's context so upvar etc. will
+            # not be affected by this intermediate method dispatcher
+            return [uplevel 1 [list $meth $this] $args]
+        }
+
+        # It is ok for constructor or destructor to be undefined. For
+        # the others, invoke "unknown" if it exists
+        if {$methodname eq "constructor" || $methodname eq "destructor"} {
+            return
+        }
+
+        set meth [::metoo::_locate_method $class_ns "unknown"]
+        if {$meth ne ""} {
+            # We need to invoke in the caller's context so upvar etc. will
+            # not be affected by this intermediate method dispatcher
+            return [uplevel 1 [list $meth $this $methodname] $args]
+        }
+
+        error "Unknown method $methodname"
+    }
+}
+
+# Given a method name, locate it in the class hierarchy. Returns
+# fully qualified method if found, else an empty string
+proc metoo::_locate_method {class_ns methodname} {
+    # See if there is a method defined in this class.
+    # Breakage if method names with wildcard chars. Too bad
+    if {[llength [info commands ${class_ns}::methods::_m_$methodname]]} {
+        # We need to invoke in the caller's context so upvar etc. will
+        # not be affected by this intermediate method dispatcher
+        return ${class_ns}::methods::_m_$methodname
+    }
+
+    # No method here, check for super class.
+    while {[info exists ${class_ns}::super]} {
+        set class_ns [set ${class_ns}::super]
+        if {[llength [info commands ${class_ns}::methods::_m_$methodname]]} {
+            return ${class_ns}::methods::_m_$methodname
+        }
+    }
+
+    return "";                  # Not found
+}
+
+proc metoo::_new {class_ns cmd args} {
+    # class_ns expected to be fully qualified
+    variable next_id
+
+    # IMPORTANT:
+    # object namespace *must* be child of class namespace. 
+    # Saves a bit of bookkeeping. Putting it somewhere else will require
+    # changes to many other places in the code.
+    set objns ${class_ns}::o#[incr next_id]
+
+    switch -exact -- $cmd {
+        create {
+            if {[llength $args] < 1} {
+                error "Insufficient args, should be: class create CLASSNAME ?args?"
+            }
+            # TBD - check if command already exists
+            # Note objname must always be fully qualified. Note cannot
+            # use namespace which here because the commmand does not
+            # yet exist.
+            set args [lassign $args objname]
+            if {[string compare :: [string range $objname 0 1]]} {
+                # Not fully qualified. Qualify based on caller namespace
+                set objname [uplevel 1 "namespace current"]::$objname
+            }
+            # Trip excess ":" - can happen in both above cases
+            set objname ::[string trimleft $objname :]
+        }
+        new {
+            set objname $objns
+        }
+        default {
+            error "Unknown command '$cmd'. Should be create or new."
+        }
+    }
+
+    # Create the namespace. The array _ is used to hold private information
+    namespace eval $objns {
+        variable _
+    }
+    set ${objns}::_(name) $objname
+
+    # When invoked by its name, call the dispatcher.
+    interp alias {} $objname {} ${class_ns}::_call $objns
+
+    # Register the object. We do this BEFORE running the constructor
+    variable _objects
+    set _objects($objname) $objns
+
+    # Invoke the constructor
+    if {[catch {
+        $objname constructor {*}$args
+    } msg]} {
+        # Undo what we did
+        set erinfo $::errorInfo
+        set ercode $::errorCode
+        rename $objname ""
+        namespace delete $objns
+        error $msg $erinfo $ercode
+    }
+
+    # TBD - does tracing cause a slowdown ?
+    # Set up trace to track when the object is renamed/destroyed
+    trace add command $objname {rename delete} [list [namespace current]::_trace_object_renames $objns]
+
+    return $objname
+}
+
+proc metoo::_trace_object_renames {objns oldname newname op} {
+    # Note the trace command fully qualifies oldname and newname
+    if {$op eq "rename"} {
+        variable _objects
+        set _objects($newname) $_objects($oldname)
+        unset _objects($oldname)
+        set ${objns}::_(name) $newname
+    } else {
+        $oldname destroy
+    }
+}
+
+proc metoo::_class_cmd {class_ns cmd args} {
+    switch -exact -- $cmd {
+        create -
+        new {
+            return [uplevel 1 [list [namespace current]::_new $class_ns $cmd] $args]
+        }
+        destroy {
+            # Destroy all objects belonging to this class
+            foreach objns [namespace children ${class_ns} o#*] {
+                [set ${objns}::_(name)] destroy
+            }
+            # Destroy all classes that inherit from this
+            foreach child_ns [array names ${class_ns}::subclasses] {
+                # Child namespace is also subclass command
+                $child_ns destroy
+            }
+            trace remove command $class_ns {rename delete} [list ::metoo::_trace_class_renames]
+            namespace delete ${class_ns}
+            rename ${class_ns} ""
+        }
+        default {
+            error "Unknown command '$cmd'. Should be create, new or destroy."
+        }
+    }
+}
+
+proc metoo::class {cmd cname definition} {
+    variable next_id
+
+    if {$cmd ne "create"} {
+        error "Syntax: class create CLASSNAME DEFINITION"
+    }
+
+    if {[uplevel 1 "namespace exists $cname"]} {
+        error "can't create class '$cname': namespace already exists with that name."
+    }
+
+    # Resolve cname into a namespace in the caller's context
+    set class_ns [uplevel 1 "namespace eval $cname {namespace current}"]
+    
+    if {[llength [info commands $class_ns]]} {
+        # Delete the namespace we just created
+        namespace delete $class_ns
+        error "can't create class '$cname': command already exists with that name."
+    }
+
+    # Define the commands/aliases that are used inside a class definition
+    foreach procname [info commands [namespace current]::define::*] {
+        interp alias {} ${class_ns}::[namespace tail $procname] {} $procname $class_ns
+    }
+
+    # Define the built in commands callable within class instance methods
+    foreach procname [info commands [namespace current]::object::*] {
+        interp alias {} ${class_ns}::methods::[namespace tail $procname] {} $procname
+    }
+
+    # Define the destroy method for the class object instances
+    namespace eval $class_ns {
+        method destroy {} {
+            set retval [my destructor]
+            # Remove trace on command rename/deletion.
+            # ${_this}::_(name) contains the object's current name on
+            # which the trace is set.
+            set me [set ${_this}::_(name)]
+            trace remove command $me {rename delete} [list ::metoo::_trace_object_renames $_this]
+            rename $me  ""
+            unset -nocomplain ::metoo::_objects($me)
+            namespace delete $_this
+            return $retval
+        }
+        method variable {args} {
+            if {[llength $args]} {
+                set cmd [list upvar 0]
+                foreach varname $args {
+                    lappend cmd ${_this}::$varname $varname
+                }
+                uplevel 1 $cmd
+            }
+        }
+    }
+
+    # Define the class. Note we do this *after* the standard
+    # definitions (destroy etc.) above so that they can
+    # be overridden by the class definition.
+    if {[catch {
+        namespace eval $class_ns $definition
+    } msg ]} {
+        namespace delete $class_ns
+        error $msg $::errorInfo $::errorCode
+    }
+
+    # Also define the call dispatcher within the class.
+    # TBD - not sure this is actually necessary any more
+    namespace eval ${class_ns} {
+        proc _call {objns methodname args} {
+            # Note this duplicates the "my" code but cannot call that as
+            # it adds another frame level which interferes with uplevel etc.
+
+            set class_ns [namespace parent $objns]
+
+            # We insert the object namespace as the first param to the command.
+            # This is passed as the first parameter "_this" to methods.
+
+            set meth [::metoo::_locate_method $class_ns $methodname]
+            if {$meth ne ""} {
+                # We need to invoke in the caller's context so upvar etc. will
+                # not be affected by this intermediate method dispatcher
+                return [uplevel 1 [list $meth $objns] $args]
+            }
+
+            # It is ok for constructor or destructor to be undefined. For
+            # the others, invoke "unknown" if it exists
+
+            if {$methodname eq "constructor" || $methodname eq "destructor"} {
+                return
+            }
+
+            set meth [::metoo::_locate_method $class_ns "unknown"]
+            if {$meth ne ""} {
+                # We need to invoke in the caller's context so upvar etc. will
+                # not be affected by this intermediate method dispatcher
+                return [uplevel 1 [list $meth $objns $methodname] $args]
+            }
+
+            error "Unknown method $methodname"
+        }
+    }
+
+    # The namespace is also a command used to create class instances
+    # TBD - check if command of that name already exists
+    interp alias {} $class_ns {} [namespace current]::_class_cmd $class_ns
+    # Set up trace to track when the class command is renamed/destroyed
+    trace add command $class_ns [list rename delete] ::metoo::_trace_class_renames
+
+    return $class_ns
+}
+
+proc metoo::_trace_class_renames {oldname newname op} {
+    if {$op eq "rename"} {
+        # TBD - this does not actually work. The rename succeeds anyways
+        error "MetOO classes may not be renamed"
+    } else {
+        $oldname destroy
+    }
+}
+
+proc metoo::introspect {type info args} {
+    switch -exact -- $type {
+        "object" {
+            variable _objects
+            switch -exact -- $info {
+                "isa" {
+                    if {[llength $args] == 0 || [llength $args] > 2} {
+                        error "wrong # args: should be \"metoo::introspect $type $info OBJNAME ?CLASS?\""
+                    }
+                    set objname [uplevel 1 [list namespace which -command [lindex $args 0]]]
+                    if {![info exists _objects($objname)]} {
+                        return 0
+                    }
+                    if {[llength $args] == 1} {
+                        # No class specified
+                        return 1
+                    }
+                    # passed classname assumed to be fully qualified
+                    set objclass [namespace parent $_objects($objname)]
+                    if {[string equal $objclass [lindex $args 1]]} {
+                        # Direct hit
+                        return 1
+                    }
+
+                    # No direct hit, check ancestors
+                    if {[lindex $args 1] in [ancestors $objclass]} {
+                        return 1
+                    }
+
+                    return 0
+                }
+
+                "list" {
+                    if {[llength $args] > 1} {
+                        error "wrong # args: should be \"metoo::introspect $type $info ?CLASS?"
+                    }
+                    variable _objects
+                    if {[llength $args] == 0} {
+                        return [array names _objects]
+                    }
+                    set objs {}
+                    foreach obj [array names _objects] {
+                        if {[introspect object isa $obj [lindex $args 0]]} {
+                            lappend objs $obj
+                        }
+                    }
+                    return $objs
+                }
+                default {
+                    error "$info subcommand not supported for $type introspection"
+                }
+            }
+        }
+
+        "class" {
+            switch -exact -- $info {
+                "ancestors" {
+                    if {[llength $args] != 1} {
+                        error "wrong # args: should be \"metoo::introspect $type $info CLASSNAME"
+                    }
+                    return [ancestors [lindex $args 0]]
+                }
+                default {
+                    error "$info subcommand not supported for $type introspection"
+                }
+            }
+        }
+        default {
+            error "$type introspection not supported"
+        }
+    }
+}
+
+proc metoo::ancestors {class_ns} {
+    # Returns ancestors of a class
+
+    set ancestors [list ]
+    while {[info exists ${class_ns}::super]} {
+        lappend ancestors [set class_ns [set ${class_ns}::super]]
+    }
+
+    return $ancestors
+}
+
+namespace eval metoo { namespace export class }
+
+# Simple sample class showing all capabilities. Anything not shown here will
+# probably not work. Call as "demo" to use metoo, or "demo oo" to use TclOO.
+# Output should be same in both cases.
+proc ::metoo::demo {{ns metoo}} {
+    ${ns}::class create Base {
+        constructor {x y} { puts "Base constructor ([self object]): $x, $y"
+        }
+        method m {} { puts "Base::m called" }
+        method n {args} { puts "Base::n called: [join $args {, }]"; my m }
+        method unknown {methodname args} { puts "Base::unknown called for $methodname [join $args {, }]"}
+        destructor { puts "Base::destructor ([self object])" }
+    }
+
+    ${ns}::class create Derived {
+        superclass Base
+        constructor {x y} { puts "Derived constructor ([self object]): $x, $y" ; next $x $y }
+        destructor { puts "Derived::destructor called ([self object])" ; next }
+        method n {args} { puts "Derived::n ([self object]): [join $args {, }]";  next {*}$args}
+        method put {val} {my variable var ; set var $val}
+        method get {varname} {my variable var ; upvar 1 $varname retvar; set retvar $var}
+    }
+
+    Base create b dum dee;      # Create named object
+    Derived create d fee fi;    # Create derived object
+    set o [Derived new fo fum]; # Create autonamed object
+    $o put 10;                  # Use of instance variable
+    $o get v;                   # Verify correct frame level ...
+    puts "v:$v";                # ...when calling methods
+    b m;                        # Direct method
+    b n;                        # Use of my to call another method
+    $o m;                       # Inherited method
+    $o n;                       # Overridden method chained to inherited
+    $o nosuchmethod arg1 arg2;  # Invoke unknown
+    $o destroy;                 # Explicit destroy
+    rename b "";                # Destroy through rename
+    Base destroy;               # Should destroy object d, Derived, Base
+}
+
+# Hack to work with the various build configuration.
+if {[info commands ::twapi::get_version] ne ""} {
+    package provide metoo [::twapi::get_version -patchlevel]
+}

src/punk86.vfs/lib/twapi4.7.2/msi.tcl

@@ -0,0 +1,403 @@
+#
+# Copyright (c) 2003-2018, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# Hack to work with the various build configuration.
+if {[info commands ::twapi::get_version] ne ""} {
+    package provide twapi_msi [::twapi::get_version -patchlevel]
+}
+
+# Rest of this file auto-generated
+
+
+# Automatically generated type library interface
+# File:    msi.dll
+# Name:    WindowsInstaller
+# GUID:    {000C1092-0000-0000-C000-000000000046}
+# Version: 1.0
+# LCID:    1033
+package require twapi_com
+
+namespace eval windowsinstaller {
+
+    # Array mapping coclass names to their guids
+    variable _coclass_guids
+
+    # Array mapping dispatch interface names to their guids
+    variable _dispatch_guids
+
+    # Returns the GUID for a coclass or empty string if not found
+    proc coclass_guid {coclass_name} {
+        variable _coclass_guids
+        if {[info exists _coclass_guids($coclass_name)]} {
+            return $_coclass_guids($coclass_name)
+        }
+        return ""
+    }
+    # Returns the GUID for a dispatch name or empty string if not found
+    proc dispatch_guid {dispatch_name} {
+        variable _dispatch_guids
+        if {[info exists _dispatch_guids($dispatch_name)]} {
+            return $_dispatch_guids($dispatch_name)
+        }
+        return ""
+    }
+    # Marks the specified object to be of a specific dispatch/coclass type
+    proc declare {typename comobj} {
+        # First check if it is the name of a dispatch interface
+        set guid [dispatch_guid $typename]
+        if {$guid ne ""} {
+            $comobj -interfaceguid $guid
+            return
+        }
+
+        # If not, check if it is the name of a coclass with a dispatch interface
+        set guid [coclass_guid $typename]
+        if {$guid ne ""} {
+            if {[info exists ::twapi::_coclass_idispatch_guids($guid)]} {
+                $comobj -interfaceguid $::twapi::_coclass_idispatch_guids($guid)
+                return
+            }
+        }
+
+        error "Could not resolve interface for $coclass_name."
+    }
+            
+    # Enum MsiUILevel
+    array set MsiUILevel {msiUILevelNoChange 0 msiUILevelDefault 1 msiUILevelNone 2 msiUILevelBasic 3 msiUILevelReduced 4 msiUILevelFull 5 msiUILevelHideCancel 32 msiUILevelProgressOnly 64 msiUILevelEndDialog 128 msiUILevelSourceResOnly 256}
+
+    # Enum MsiReadStream
+    array set MsiReadStream {msiReadStreamInteger 0 msiReadStreamBytes 1 msiReadStreamAnsi 2 msiReadStreamDirect 3}
+
+    # Enum MsiRunMode
+    array set MsiRunMode {msiRunModeAdmin 0 msiRunModeAdvertise 1 msiRunModeMaintenance 2 msiRunModeRollbackEnabled 3 msiRunModeLogEnabled 4 msiRunModeOperations 5 msiRunModeRebootAtEnd 6 msiRunModeRebootNow 7 msiRunModeCabinet 8 msiRunModeSourceShortNames 9 msiRunModeTargetShortNames 10 msiRunModeWindows9x 12 msiRunModeZawEnabled 13 msiRunModeScheduled 16 msiRunModeRollback 17 msiRunModeCommit 18}
+
+    # Enum MsiDatabaseState
+    array set MsiDatabaseState {msiDatabaseStateRead 0 msiDatabaseStateWrite 1}
+
+    # Enum MsiViewModify
+    array set MsiViewModify {msiViewModifySeek -1 msiViewModifyRefresh 0 msiViewModifyInsert 1 msiViewModifyUpdate 2 msiViewModifyAssign 3 msiViewModifyReplace 4 msiViewModifyMerge 5 msiViewModifyDelete 6 msiViewModifyInsertTemporary 7 msiViewModifyValidate 8 msiViewModifyValidateNew 9 msiViewModifyValidateField 10 msiViewModifyValidateDelete 11}
+
+    # Enum MsiColumnInfo
+    array set MsiColumnInfo {msiColumnInfoNames 0 msiColumnInfoTypes 1}
+
+    # Enum MsiTransformError
+    array set MsiTransformError {msiTransformErrorNone 0 msiTransformErrorAddExistingRow 1 msiTransformErrorDeleteNonExistingRow 2 msiTransformErrorAddExistingTable 4 msiTransformErrorDeleteNonExistingTable 8 msiTransformErrorUpdateNonExistingRow 16 msiTransformErrorChangeCodePage 32 msiTransformErrorViewTransform 256}
+
+    # Enum MsiEvaluateCondition
+    array set MsiEvaluateCondition {msiEvaluateConditionFalse 0 msiEvaluateConditionTrue 1 msiEvaluateConditionNone 2 msiEvaluateConditionError 3}
+
+    # Enum MsiTransformValidation
+    array set MsiTransformValidation {msiTransformValidationNone 0 msiTransformValidationLanguage 1 msiTransformValidationProduct 2 msiTransformValidationPlatform 4 msiTransformValidationMajorVer 8 msiTransformValidationMinorVer 16 msiTransformValidationUpdateVer 32 msiTransformValidationLess 64 msiTransformValidationLessOrEqual 128 msiTransformValidationEqual 256 msiTransformValidationGreaterOrEqual 512 msiTransformValidationGreater 1024 msiTransformValidationUpgradeCode 2048}
+
+    # Enum MsiDoActionStatus
+    array set MsiDoActionStatus {msiDoActionStatusNoAction 0 msiDoActionStatusSuccess 1 msiDoActionStatusUserExit 2 msiDoActionStatusFailure 3 msiDoActionStatusSuspend 4 msiDoActionStatusFinished 5 msiDoActionStatusWrongState 6 msiDoActionStatusBadActionData 7}
+
+    # Enum MsiMessageStatus
+    array set MsiMessageStatus {msiMessageStatusError -1 msiMessageStatusNone 0 msiMessageStatusOk 1 msiMessageStatusCancel 2 msiMessageStatusAbort 3 msiMessageStatusRetry 4 msiMessageStatusIgnore 5 msiMessageStatusYes 6 msiMessageStatusNo 7}
+
+    # Enum MsiMessageType
+    array set MsiMessageType {msiMessageTypeFatalExit 0 msiMessageTypeError 16777216 msiMessageTypeWarning 33554432 msiMessageTypeUser 50331648 msiMessageTypeInfo 67108864 msiMessageTypeFilesInUse 83886080 msiMessageTypeResolveSource 100663296 msiMessageTypeOutOfDiskSpace 117440512 msiMessageTypeActionStart 134217728 msiMessageTypeActionData 150994944 msiMessageTypeProgress 167772160 msiMessageTypeCommonData 184549376 msiMessageTypeOk 0 msiMessageTypeOkCancel 1 msiMessageTypeAbortRetryIgnore 2 msiMessageTypeYesNoCancel 3 msiMessageTypeYesNo 4 msiMessageTypeRetryCancel 5 msiMessageTypeDefault1 0 msiMessageTypeDefault2 256 msiMessageTypeDefault3 512}
+
+    # Enum MsiInstallState
+    array set MsiInstallState {msiInstallStateNotUsed -7 msiInstallStateBadConfig -6 msiInstallStateIncomplete -5 msiInstallStateSourceAbsent -4 msiInstallStateInvalidArg -2 msiInstallStateUnknown -1 msiInstallStateBroken 0 msiInstallStateAdvertised 1 msiInstallStateRemoved 1 msiInstallStateAbsent 2 msiInstallStateLocal 3 msiInstallStateSource 4 msiInstallStateDefault 5}
+
+    # Enum MsiCostTree
+    array set MsiCostTree {msiCostTreeSelfOnly 0 msiCostTreeChildren 1 msiCostTreeParents 2}
+
+    # Enum MsiReinstallMode
+    array set MsiReinstallMode {msiReinstallModeFileMissing 2 msiReinstallModeFileOlderVersion 4 msiReinstallModeFileEqualVersion 8 msiReinstallModeFileExact 16 msiReinstallModeFileVerify 32 msiReinstallModeFileReplace 64 msiReinstallModeMachineData 128 msiReinstallModeUserData 256 msiReinstallModeShortcut 512 msiReinstallModePackage 1024}
+
+    # Enum MsiInstallType
+    array set MsiInstallType {msiInstallTypeDefault 0 msiInstallTypeNetworkImage 1 msiInstallTypeSingleInstance 2}
+
+    # Enum MsiInstallMode
+    array set MsiInstallMode {msiInstallModeNoSourceResolution -3 msiInstallModeNoDetection -2 msiInstallModeExisting -1 msiInstallModeDefault 0}
+
+    # Enum MsiSignatureInfo
+    array set MsiSignatureInfo {msiSignatureInfoCertificate 0 msiSignatureInfoHash 1}
+
+    # Enum MsiInstallContext
+    array set MsiInstallContext {msiInstallContextFirstVisible 0 msiInstallContextUserManaged 1 msiInstallContextUser 2 msiInstallContextMachine 4 msiInstallContextAllUserManaged 8}
+
+    # Enum MsiInstallSourceType
+    array set MsiInstallSourceType {msiInstallSourceTypeUnknown 0 msiInstallSourceTypeNetwork 1 msiInstallSourceTypeURL 2 msiInstallSourceTypeMedia 4}
+
+    # Enum MsiAssemblyType
+    array set MsiAssemblyType {msiProvideAssemblyNet 0 msiProvideAssemblyWin32 1}
+
+    # Enum MsiProductScriptInfo
+    array set MsiProductScriptInfo {msiProductScriptInfoProductCode 0 msiProductScriptInfoProductLanguage 1 msiProductScriptInfoProductVersion 2 msiProductScriptInfoProductName 3 msiProductScriptInfoPackageName 4}
+
+    # Enum MsiAdvertiseProductContext
+    array set MsiAdvertiseProductContext {msiAdvertiseProductMachine 0 msiAdvertiseProductUser 1}
+
+    # Enum Constants
+    array set Constants {msiDatabaseNullInteger -2147483648}
+
+    # Enum MsiOpenDatabaseMode
+    array set MsiOpenDatabaseMode {msiOpenDatabaseModeReadOnly 0 msiOpenDatabaseModeTransact 1 msiOpenDatabaseModeDirect 2 msiOpenDatabaseModeCreate 3 msiOpenDatabaseModeCreateDirect 4 msiOpenDatabaseModePatchFile 32}
+
+    # Enum MsiSignatureOption
+    array set MsiSignatureOption {msiSignatureOptionInvalidHashFatal 1}
+
+    # Enum MsiAdvertiseProductPlatform
+    array set MsiAdvertiseProductPlatform {msiAdvertiseCurrentPlatform 0 msiAdvertiseX86Platform 1 msiAdvertiseIA64Platform 2 msiAdvertiseX64Platform 4}
+
+    # Enum MsiAdvertiseProductOptions
+    array set MsiAdvertiseProductOptions {msiAdvertiseDefault 0 msiAdvertiseSingleInstance 1}
+
+    # Enum MsiAdvertiseScriptFlags
+    array set MsiAdvertiseScriptFlags {msiAdvertiseScriptCacheInfo 1 msiAdvertiseScriptShortcuts 4 msiAdvertiseScriptMachineAssign 8 msiAdvertiseScriptConfigurationRegistration 32 msiAdvertiseScriptValidateTransformsList 64 msiAdvertiseScriptClassInfoRegistration 128 msiAdvertiseScriptExtensionInfoRegistration 256 msiAdvertiseScriptAppInfo 384 msiAdvertiseScriptRegData 416}
+}
+
+# Dispatch Interface Installer
+set windowsinstaller::_dispatch_guids(Installer) "{000C1090-0000-0000-C000-000000000046}"
+# Installer Methods
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} CreateRecord 1033 1 {1 1033 1 {26 {29 256}} {{3 1}} Count}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} OpenPackage 1033 1 {2 1033 1 {26 {29 512}} {{12 1} {3 {49 {3 0}}}} {PackagePath Options}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} OpenProduct 1033 1 {3 1033 1 {26 {29 512}} {{8 1}} ProductCode}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} OpenDatabase 1033 1 {4 1033 1 {26 {29 768}} {{8 1} {12 1}} {DatabasePath OpenMode}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} SummaryInformation 1033 2 {5 1033 2 {26 {29 1024}} {{8 1} {3 {49 {3 0}}}} {PackagePath UpdateCount}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} EnableLog 1033 1 {7 1033 1 24 {{8 1} {8 1}} {LogMode LogFile}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} InstallProduct 1033 1 {8 1033 1 24 {{8 1} {8 {49 {8 0}}}} {PackagePath PropertyValues}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Version 1033 2 {9 1033 2 8 {} {}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} LastErrorRecord 1033 1 {10 1033 1 {26 {29 256}} {} {}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} RegistryValue 1033 1 {11 1033 1 8 {{12 1} {8 1} {12 17}} {Root Key Value}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileAttributes 1033 1 {13 1033 1 3 {{8 1}} FilePath}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileSize 1033 1 {15 1033 1 3 {{8 1}} FilePath}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileVersion 1033 1 {16 1033 1 8 {{8 1} {12 17}} {FilePath Language}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Environment 1033 2 {12 1033 2 8 {{8 1}} Variable}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Environment 1033 4 {12 1033 4 24 {{8 1} {8 1}} Variable}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductState 1033 2 {17 1033 2 {29 2432} {{8 1}} Product}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductInfo 1033 2 {18 1033 2 8 {{8 1} {8 1}} {Product Attribute}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ConfigureProduct 1033 1 {19 1033 1 24 {{8 1} {3 1} {3 1}} {Product InstallLevel InstallState}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ReinstallProduct 1033 1 {20 1033 1 24 {{8 1} {3 1}} {Product ReinstallMode}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} CollectUserInfo 1033 1 {21 1033 1 24 {{8 1}} Product}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ApplyPatch 1033 1 {22 1033 1 24 {{8 1} {8 1} {3 1} {8 1}} {PatchPackage InstallPackage InstallType CommandLine}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FeatureParent 1033 2 {23 1033 2 8 {{8 1} {8 1}} {Product Feature}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FeatureState 1033 2 {24 1033 2 {29 2432} {{8 1} {8 1}} {Product Feature}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} UseFeature 1033 1 {25 1033 1 24 {{8 1} {8 1} {3 1}} {Product Feature InstallMode}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FeatureUsageCount 1033 2 {26 1033 2 3 {{8 1} {8 1}} {Product Feature}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FeatureUsageDate 1033 2 {27 1033 2 7 {{8 1} {8 1}} {Product Feature}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ConfigureFeature 1033 1 {28 1033 1 24 {{8 1} {8 1} {3 1}} {Product Feature InstallState}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ReinstallFeature 1033 1 {29 1033 1 24 {{8 1} {8 1} {3 1}} {Product Feature ReinstallMode}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProvideComponent 1033 1 {30 1033 1 8 {{8 1} {8 1} {8 1} {3 1}} {Product Feature Component InstallMode}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentPath 1033 2 {31 1033 2 8 {{8 1} {8 1}} {Product Component}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProvideQualifiedComponent 1033 1 {32 1033 1 8 {{8 1} {8 1} {3 1}} {Category Qualifier InstallMode}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} QualifierDescription 1033 2 {33 1033 2 8 {{8 1} {8 1}} {Category Qualifier}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentQualifiers 1033 2 {34 1033 2 {26 {29 3328}} {{8 1}} Category}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Products 1033 2 {35 1033 2 {26 {29 3328}} {} {}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Features 1033 2 {36 1033 2 {26 {29 3328}} {{8 1}} Product}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Components 1033 2 {37 1033 2 {26 {29 3328}} {} {}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentClients 1033 2 {38 1033 2 {26 {29 3328}} {{8 1}} Component}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Patches 1033 2 {39 1033 2 {26 {29 3328}} {{8 1}} Product}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} RelatedProducts 1033 2 {40 1033 2 {26 {29 3328}} {{8 1}} UpgradeCode}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} PatchInfo 1033 2 {41 1033 2 8 {{8 1} {8 1}} {Patch Attribute}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} PatchTransforms 1033 2 {42 1033 2 8 {{8 1} {8 1}} {Product Patch}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} AddSource 1033 1 {43 1033 1 24 {{8 1} {8 1} {8 1}} {Product User Source}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ClearSourceList 1033 1 {44 1033 1 24 {{8 1} {8 1}} {Product User}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ForceSourceListResolution 1033 1 {45 1033 1 24 {{8 1} {8 1}} {Product User}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} GetShortcutTarget 1033 2 {46 1033 2 {26 {29 256}} {{8 1}} ShortcutPath}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileHash 1033 1 {47 1033 1 {26 {29 256}} {{8 1} {3 1}} {FilePath Options}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} FileSignatureInfo 1033 1 {48 1033 1 {27 17} {{8 1} {3 1} {3 1}} {FilePath Options Format}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} RemovePatches 1033 1 {49 1033 1 24 {{8 1} {8 1} {3 1} {8 {49 {8 0}}}} {PatchList Product UninstallType PropertyList}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ApplyMultiplePatches 1033 1 {51 1033 1 24 {{8 1} {8 1} {8 1}} {PatchPackage Product PropertiesList}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Product 1033 2 {53 1033 2 25 {{8 1} {8 1} {3 1} {{26 9} 10}} {Product UserSid iContext retval}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} Patch 1033 2 {56 1033 2 25 {{8 1} {8 1} {8 1} {3 1} {{26 9} 10}} {PatchCode ProductCode UserSid iContext retval}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductsEx 1033 2 {52 1033 2 {26 {29 2816}} {{8 1} {8 1} {3 1}} {Product UserSid Contexts}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} PatchesEx 1033 2 {55 1033 2 {26 {29 2816}} {{8 1} {8 1} {3 1} {3 1}} {Product UserSid Contexts filter}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ExtractPatchXMLData 1033 1 {57 1033 1 8 {{8 1}} PatchPath}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductCode 1033 2 {58 1033 2 8 {{8 1}} Component}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductElevated 1033 2 {59 1033 2 11 {{8 1}} Product}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProvideAssembly 1033 1 {60 1033 1 8 {{8 1} {8 1} {3 1} {3 1}} {Assembly Context InstallMode AssemblyInfo}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ProductInfoFromScript 1033 2 {61 1033 2 12 {{8 1} {3 1}} {ScriptFile ProductInfo}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} AdvertiseProduct 1033 1 {62 1033 1 24 {{8 1} {3 1} {8 {49 {8 0}}} {3 {49 {3 0}}} {3 {49 {3 0}}}} {PackagePath iContext Transforms Language Options}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} CreateAdvertiseScript 1033 1 {63 1033 1 24 {{8 1} {8 1} {8 {49 {8 0}}} {3 {49 {3 0}}} {3 {49 {3 0}}} {3 {49 {3 0}}}} {PackagePath ScriptFilePath Transforms Language Platform Options}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} AdvertiseScript 1033 1 {64 1033 1 24 {{8 1} {3 1} {11 1}} {ScriptPath ScriptFlags RemoveItems}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} PatchFiles 1033 2 {65 1033 2 {26 {29 3328}} {{8 1} {8 1}} {Product PatchPackages}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentsEx 1033 2 {66 1033 2 {26 {29 2816}} {{8 1} {3 1}} {UserSid Context}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentClientsEx 1033 2 {67 1033 2 {26 {29 2816}} {{8 1} {8 1} {3 1}} {ComponentCode UserSid Context}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} ComponentPathEx 1033 2 {9068 1033 2 {26 {29 4480}} {{8 1} {8 1} {8 1} {3 1}} {ProductCode ComponentCode UserSid Context}}
+# Installer Properties
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} UILevel 1033 2 {6 1033 2 {29 128} {} {}}
+::twapi::dispatch_prototype_set {{000C1090-0000-0000-C000-000000000046}} UILevel 1033 4 {6 1033 4 24 {{{29 128} 1}} {}}
+
+# Dispatch Interface Record
+set windowsinstaller::_dispatch_guids(Record) "{000C1093-0000-0000-C000-000000000046}"
+# Record Methods
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} StringData 1033 2 {1 1033 2 8 {{3 1}} Field}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} StringData 1033 4 {1 1033 4 24 {{3 1} {8 1}} Field}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} IntegerData 1033 2 {2 1033 2 3 {{3 1}} Field}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} IntegerData 1033 4 {2 1033 4 24 {{3 1} {3 1}} Field}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} SetStream 1033 1 {3 1033 1 24 {{3 1} {8 1}} {Field FilePath}}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} ReadStream 1033 1 {4 1033 1 8 {{3 1} {3 1} {3 1}} {Field Length Format}}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} FieldCount 1033 2 {0 1033 2 3 {} {}}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} IsNull 1033 2 {6 1033 2 11 {{3 1}} Field}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} DataSize 1033 2 {5 1033 2 3 {{3 1}} Field}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} ClearData 1033 1 {7 1033 1 24 {} {}}
+::twapi::dispatch_prototype_set {{000C1093-0000-0000-C000-000000000046}} FormatText 1033 1 {8 1033 1 8 {} {}}
+
+# Dispatch Interface Session
+set windowsinstaller::_dispatch_guids(Session) "{000C109E-0000-0000-C000-000000000046}"
+# Session Methods
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Installer 1033 2 {1 1033 2 {26 {29 0}} {} {}}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Property 1033 2 {2 1033 2 8 {{8 1}} Name}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Property 1033 4 {2 1033 4 24 {{8 1} {8 1}} Name}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Language 1033 2 {3 1033 2 3 {} {}}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Mode 1033 2 {4 1033 2 11 {{3 1}} Flag}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Mode 1033 4 {4 1033 4 24 {{3 1} {11 1}} Flag}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Database 1033 2 {5 1033 2 {26 {29 768}} {} {}}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} SourcePath 1033 2 {6 1033 2 8 {{8 1}} Folder}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} TargetPath 1033 2 {7 1033 2 8 {{8 1}} Folder}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} TargetPath 1033 4 {7 1033 4 24 {{8 1} {8 1}} Folder}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} DoAction 1033 1 {8 1033 1 {29 2048} {{8 1}} Action}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Sequence 1033 1 {9 1033 1 {29 2048} {{8 1} {12 17}} {Table Mode}}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} EvaluateCondition 1033 1 {10 1033 1 {29 1792} {{8 1}} Expression}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FormatRecord 1033 1 {11 1033 1 8 {{9 1}} Record}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} Message 1033 1 {12 1033 1 {29 2176} {{3 1} {9 1}} {Kind Record}}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureCurrentState 1033 2 {13 1033 2 {29 2432} {{8 1}} Feature}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureRequestState 1033 2 {14 1033 2 {29 2432} {{8 1}} Feature}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureRequestState 1033 4 {14 1033 4 24 {{8 1} {3 1}} Feature}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureValidStates 1033 2 {15 1033 2 3 {{8 1}} Feature}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureCost 1033 2 {16 1033 2 3 {{8 1} {3 1} {3 1}} {Feature CostTree State}}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ComponentCurrentState 1033 2 {17 1033 2 {29 2432} {{8 1}} Component}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ComponentRequestState 1033 2 {18 1033 2 {29 2432} {{8 1}} Component}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ComponentRequestState 1033 4 {18 1033 4 24 {{8 1} {3 1}} Component}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} SetInstallLevel 1033 1 {19 1033 1 24 {{3 1}} Level}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} VerifyDiskSpace 1033 2 {20 1033 2 11 {} {}}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ProductProperty 1033 2 {21 1033 2 8 {{8 1}} Property}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} FeatureInfo 1033 2 {22 1033 2 {26 {29 2688}} {{8 1}} Feature}
+::twapi::dispatch_prototype_set {{000C109E-0000-0000-C000-000000000046}} ComponentCosts 1033 2 {23 1033 2 {26 {29 2816}} {{8 1} {3 1}} {Component State}}
+
+# Dispatch Interface Database
+set windowsinstaller::_dispatch_guids(Database) "{000C109D-0000-0000-C000-000000000046}"
+# Database Methods
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} DatabaseState 1033 2 {1 1033 2 {29 896} {} {}}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} SummaryInformation 1033 2 {2 1033 2 {26 {29 1024}} {{3 {49 {3 0}}}} UpdateCount}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} OpenView 1033 1 {3 1033 1 {26 {29 1152}} {{8 1}} Sql}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} Commit 1033 1 {4 1033 1 24 {} {}}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} PrimaryKeys 1033 2 {5 1033 2 {26 {29 256}} {{8 1}} Table}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} Import 1033 1 {6 1033 1 24 {{8 1} {8 1}} {Folder File}}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} Export 1033 1 {7 1033 1 24 {{8 1} {8 1} {8 1}} {Table Folder File}}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} Merge 1033 1 {8 1033 1 11 {{9 1} {8 {49 {8 0}}}} {Database ErrorTable}}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} GenerateTransform 1033 1 {9 1033 1 11 {{9 1} {8 {49 {8 0}}}} {ReferenceDatabase TransformFile}}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} ApplyTransform 1033 1 {10 1033 1 24 {{8 1} {3 1}} {TransformFile ErrorConditions}}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} EnableUIPreview 1033 1 {11 1033 1 {26 {29 1664}} {} {}}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} TablePersistent 1033 2 {12 1033 2 {29 1792} {{8 1}} Table}
+::twapi::dispatch_prototype_set {{000C109D-0000-0000-C000-000000000046}} CreateTransformSummaryInfo 1033 1 {13 1033 1 24 {{9 1} {8 1} {3 1} {3 1}} {ReferenceDatabase TransformFile ErrorConditions Validation}}
+
+# Dispatch Interface SummaryInfo
+set windowsinstaller::_dispatch_guids(SummaryInfo) "{000C109B-0000-0000-C000-000000000046}"
+# SummaryInfo Methods
+::twapi::dispatch_prototype_set {{000C109B-0000-0000-C000-000000000046}} Property 1033 2 {1 1033 2 12 {{3 1}} Pid}
+::twapi::dispatch_prototype_set {{000C109B-0000-0000-C000-000000000046}} Property 1033 4 {1 1033 4 24 {{3 1} {12 1}} Pid}
+::twapi::dispatch_prototype_set {{000C109B-0000-0000-C000-000000000046}} PropertyCount 1033 2 {2 1033 2 3 {} {}}
+::twapi::dispatch_prototype_set {{000C109B-0000-0000-C000-000000000046}} Persist 1033 1 {3 1033 1 24 {} {}}
+
+# Dispatch Interface View
+set windowsinstaller::_dispatch_guids(View) "{000C109C-0000-0000-C000-000000000046}"
+# View Methods
+::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} Execute 1033 1 {1 1033 1 24 {{9 {49 {3 0}}}} Params}
+::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} Fetch 1033 1 {2 1033 1 {26 {29 256}} {} {}}
+::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} Modify 1033 1 {3 1033 1 24 {{3 1} {9 0}} {Mode Record}}
+::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} ColumnInfo 1033 2 {5 1033 2 {26 {29 256}} {{3 1}} Info}
+::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} Close 1033 1 {4 1033 1 24 {} {}}
+::twapi::dispatch_prototype_set {{000C109C-0000-0000-C000-000000000046}} GetError 1033 1 {6 1033 1 8 {} {}}
+
+# Dispatch Interface UIPreview
+set windowsinstaller::_dispatch_guids(UIPreview) "{000C109A-0000-0000-C000-000000000046}"
+# UIPreview Methods
+::twapi::dispatch_prototype_set {{000C109A-0000-0000-C000-000000000046}} Property 1033 2 {1 1033 2 8 {{8 1}} Name}
+::twapi::dispatch_prototype_set {{000C109A-0000-0000-C000-000000000046}} Property 1033 4 {1 1033 4 24 {{8 1} {8 1}} Name}
+::twapi::dispatch_prototype_set {{000C109A-0000-0000-C000-000000000046}} ViewDialog 1033 1 {2 1033 1 24 {{8 1}} Dialog}
+::twapi::dispatch_prototype_set {{000C109A-0000-0000-C000-000000000046}} ViewBillboard 1033 1 {3 1033 1 24 {{8 1} {8 1}} {Control Billboard}}
+
+# Dispatch Interface FeatureInfo
+set windowsinstaller::_dispatch_guids(FeatureInfo) "{000C109F-0000-0000-C000-000000000046}"
+# FeatureInfo Methods
+::twapi::dispatch_prototype_set {{000C109F-0000-0000-C000-000000000046}} Title 1033 2 {1 1033 2 8 {} {}}
+::twapi::dispatch_prototype_set {{000C109F-0000-0000-C000-000000000046}} Description 1033 2 {2 1033 2 8 {} {}}
+# FeatureInfo Properties
+::twapi::dispatch_prototype_set {{000C109F-0000-0000-C000-000000000046}} Attributes 1033 2 {3 1033 2 3 {} {}}
+::twapi::dispatch_prototype_set {{000C109F-0000-0000-C000-000000000046}} Attributes 1033 4 {3 1033 4 24 {{3 1}} {}}
+
+# Dispatch Interface RecordList
+set windowsinstaller::_dispatch_guids(RecordList) "{000C1096-0000-0000-C000-000000000046}"
+# RecordList Methods
+::twapi::dispatch_prototype_set {{000C1096-0000-0000-C000-000000000046}} _NewEnum 1033 1 {-4 1033 1 13 {} {}}
+::twapi::dispatch_prototype_set {{000C1096-0000-0000-C000-000000000046}} Item 1033 2 {0 1033 2 {26 {29 256}} {{3 0}} Index}
+::twapi::dispatch_prototype_set {{000C1096-0000-0000-C000-000000000046}} Count 1033 2 {1 1033 2 3 {} {}}
+
+# Dispatch Interface StringList
+set windowsinstaller::_dispatch_guids(StringList) "{000C1095-0000-0000-C000-000000000046}"
+# StringList Methods
+::twapi::dispatch_prototype_set {{000C1095-0000-0000-C000-000000000046}} _NewEnum 1033 1 {-4 1033 1 13 {} {}}
+::twapi::dispatch_prototype_set {{000C1095-0000-0000-C000-000000000046}} Item 1033 2 {0 1033 2 8 {{3 0}} Index}
+::twapi::dispatch_prototype_set {{000C1095-0000-0000-C000-000000000046}} Count 1033 2 {1 1033 2 3 {} {}}
+
+# Dispatch Interface Product
+set windowsinstaller::_dispatch_guids(Product) "{000C10A0-0000-0000-C000-000000000046}"
+# Product Methods
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} ProductCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} UserSid 1033 2 {2 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} Context 1033 2 {3 1033 2 25 {{{26 3} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} State 1033 2 {4 1033 2 25 {{{26 3} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} InstallProperty 1033 2 {5 1033 2 25 {{8 1} {{26 8} 10}} {Name retval}}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} ComponentState 1033 2 {6 1033 2 25 {{8 1} {{26 3} 10}} {Component retval}}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} FeatureState 1033 2 {7 1033 2 25 {{8 1} {{26 3} 10}} {Feature retval}}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} Sources 1033 2 {14 1033 2 25 {{3 1} {{26 9} 10}} {SourceType retval}}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} MediaDisks 1033 2 {15 1033 2 25 {{{26 9} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListAddSource 1033 1 {8 1033 1 25 {{3 1} {8 1} {3 1}} {iSourceType Source dwIndex}}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListAddMediaDisk 1033 1 {9 1033 1 25 {{3 1} {8 1} {8 1}} {dwDiskId VolumeLabel DiskPrompt}}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListClearSource 1033 1 {10 1033 1 25 {{3 1} {8 1}} {iSourceType Source}}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListClearMediaDisk 1033 1 {11 1033 1 25 {{3 1}} iDiskId}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListClearAll 1033 1 {12 1033 1 25 {{3 1}} iSourceType}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListForceResolution 1033 1 {13 1033 1 25 {} {}}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListInfo 1033 2 {16 1033 2 25 {{8 1} {{26 8} 10}} {Property retval}}
+::twapi::dispatch_prototype_set {{000C10A0-0000-0000-C000-000000000046}} SourceListInfo 1033 4 {16 1033 4 25 {{8 1} {8 1}} {Property retval}}
+
+# Dispatch Interface Patch
+set windowsinstaller::_dispatch_guids(Patch) "{000C10A1-0000-0000-C000-000000000046}"
+# Patch Methods
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} PatchCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} ProductCode 1033 2 {2 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} UserSid 1033 2 {3 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} Context 1033 2 {4 1033 2 25 {{{26 3} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} State 1033 2 {5 1033 2 25 {{{26 3} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} Sources 1033 2 {12 1033 2 25 {{3 1} {{26 9} 10}} {SourceType retval}}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} MediaDisks 1033 2 {13 1033 2 25 {{{26 9} 10}} retval}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListAddSource 1033 1 {6 1033 1 25 {{3 1} {8 1} {3 1}} {iSourceType Source dwIndex}}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListAddMediaDisk 1033 1 {7 1033 1 25 {{3 1} {8 1} {8 1}} {dwDiskId VolumeLabel DiskPrompt}}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListClearSource 1033 1 {8 1033 1 25 {{3 1} {8 1}} {iSourceType Source}}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListClearMediaDisk 1033 1 {9 1033 1 25 {{3 1}} iDiskId}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListClearAll 1033 1 {10 1033 1 25 {{3 1}} iSourceType}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListForceResolution 1033 1 {11 1033 1 25 {} {}}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListInfo 1033 2 {14 1033 2 25 {{8 1} {{26 8} 10}} {Property retval}}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} SourceListInfo 1033 4 {14 1033 4 25 {{8 1} {8 1}} {Property retval}}
+::twapi::dispatch_prototype_set {{000C10A1-0000-0000-C000-000000000046}} PatchProperty 1033 2 {15 1033 2 25 {{8 1} {{26 8} 10}} {Property Value}}
+
+# Dispatch Interface ComponentPath
+set windowsinstaller::_dispatch_guids(ComponentPath) "{000C1099-0000-0000-C000-000000000046}"
+# ComponentPath Methods
+::twapi::dispatch_prototype_set {{000C1099-0000-0000-C000-000000000046}} ComponentCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C1099-0000-0000-C000-000000000046}} Path 1033 2 {2 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C1099-0000-0000-C000-000000000046}} State 1033 2 {3 1033 2 25 {{{26 3} 10}} retval}
+
+# Dispatch Interface Component
+set windowsinstaller::_dispatch_guids(Component) "{000C1097-0000-0000-C000-000000000046}"
+# Component Methods
+::twapi::dispatch_prototype_set {{000C1097-0000-0000-C000-000000000046}} ComponentCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C1097-0000-0000-C000-000000000046}} UserSid 1033 2 {2 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C1097-0000-0000-C000-000000000046}} Context 1033 2 {3 1033 2 25 {{{26 3} 10}} retval}
+
+# Dispatch Interface ComponentClient
+set windowsinstaller::_dispatch_guids(ComponentClient) "{000C1098-0000-0000-C000-000000000046}"
+# ComponentClient Methods
+::twapi::dispatch_prototype_set {{000C1098-0000-0000-C000-000000000046}} ProductCode 1033 2 {2 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C1098-0000-0000-C000-000000000046}} ComponentCode 1033 2 {1 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C1098-0000-0000-C000-000000000046}} UserSid 1033 2 {3 1033 2 25 {{{26 8} 10}} retval}
+::twapi::dispatch_prototype_set {{000C1098-0000-0000-C000-000000000046}} Context 1033 2 {4 1033 2 25 {{{26 3} 10}} retval}
+

src/punk86.vfs/lib/twapi4.7.2/mstask.tcl

@@ -0,0 +1,745 @@
+#
+# Copyright (c) 2006-2013 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# Task scheduler API
+
+package require twapi_com
+
+namespace eval twapi {
+    variable CLSID_ITaskScheduler {{148BD52A-A2AB-11CE-B11F-00AA00530503}}
+    variable CLSID_ITask          {{148BD520-A2AB-11CE-B11F-00AA00530503}}
+}
+
+# Return an instance of the task scheduler
+proc twapi::itaskscheduler_new {args} {
+    array set opts [parseargs args {
+        system.arg
+    } -maxleftover 0]
+
+    # Get ITaskScheduler interface
+    set its [com_create_instance $::twapi::CLSID_ITaskScheduler -model inprocserver -interface ITaskScheduler -raw]
+    if {![info exists opts(system)]} {
+        return $its
+    }
+    trap {
+        itaskscheduler_set_target_system $its $opts(system)
+    } onerror {} {
+        IUnknown_Release $its
+        rethrow
+    }
+    return $its
+}
+
+interp alias {} ::twapi::itaskscheduler_release {} ::twapi::IUnknown_Release
+
+# Return a new task interface
+proc twapi::itaskscheduler_new_itask {its taskname} {
+    set iid_itask [name_to_iid ITask]
+    set iunk [ITaskScheduler_NewWorkItem $its $taskname $::twapi::CLSID_ITask $iid_itask]
+    trap {
+        set itask [Twapi_IUnknown_QueryInterface $iunk $iid_itask ITask]
+    } finally {
+        IUnknown_Release $iunk
+    }
+    return $itask
+}
+
+# Get an existing task
+proc twapi::itaskscheduler_get_itask {its taskname} {
+    set iid_itask [name_to_iid ITask]
+    set iunk [ITaskScheduler_Activate $its $taskname $iid_itask]
+    trap {
+        set itask [Twapi_IUnknown_QueryInterface $iunk $iid_itask ITask]
+    } finally {
+        IUnknown_Release $iunk
+    }
+    return $itask
+}
+
+# Check if an itask exists
+proc twapi::itaskscheduler_task_exists {its taskname} {
+    return [expr {[ITaskScheduler_IsOfType $its $taskname [name_to_iid ITask]] == 0 ? true : false}]
+}
+
+# Return list of tasks
+proc twapi::itaskscheduler_get_tasks {its} {
+    set ienum [ITaskScheduler_Enum $its]
+    trap {
+        set result [list ]
+        set more 1
+        while {$more} {
+            lassign [IEnumWorkItems_Next $ienum 20] more items
+            set result [concat $result $items]
+        }
+    } finally {
+        IUnknown_Release $ienum
+    }
+    return $result
+}
+
+# Sets the specified properties of the ITask
+proc twapi::itask_configure {itask args} {
+
+    array set opts [parseargs args {
+        application.arg
+        maxruntime.int
+        params.arg
+        priority.arg
+        workingdir.arg
+        account.arg
+        password.arg
+        comment.arg
+        creator.arg
+        data.arg
+        idlewait.int
+        idlewaitdeadline.int
+        interactive.bool
+        deletewhendone.bool
+        disabled.bool
+        hidden.bool
+        runonlyifloggedon.bool
+        startonlyifidle.bool
+        resumesystem.bool
+        killonidleend.bool
+        restartonidleresume.bool
+        dontstartonbatteries.bool
+        killifonbatteries.bool
+    } -maxleftover 0]
+
+    if {[info exists opts(priority)]} {
+        switch -exact -- $opts(priority) {
+            normal      {set opts(priority) 0x00000020}
+            abovenormal {set opts(priority) 0x00008000}
+            belownormal {set opts(priority) 0x00004000}
+            high        {set opts(priority) 0x00000080}
+            realtime    {set opts(priority) 0x00000100}
+            idle        {set opts(priority) 0x00000040}
+            default     {error "Unknown priority '$opts(priority)'. Must be one of 'normal', 'high', 'idle' or 'realtime'"}
+        }
+    }
+
+    foreach {opt fn} {
+        application ITask_SetApplicationName
+        maxruntime  ITask_SetMaxRunTime
+        params      ITask_SetParameters
+        workingdir  ITask_SetWorkingDirectory
+        priority    ITask_SetPriority
+        comment            IScheduledWorkItem_SetComment
+        creator            IScheduledWorkItem_SetCreator
+        data               IScheduledWorkItem_SetWorkItemData
+        errorretrycount    IScheduledWorkItem_SetErrorRetryCount
+        errorretryinterval IScheduledWorkItem_SetErrorRetryInterval
+    } {
+        if {[info exists opts($opt)]} {
+            $fn  $itask $opts($opt)
+        }
+    }
+
+    if {[info exists opts(account)]} {
+        if {$opts(account) ne ""} {
+            if {![info exists opts(password)]} {
+                error "Option -password must be specified if -account is specified"
+            }
+        } else {
+            # System account. Set password to NULL pointer indicated
+            # by magic null pointer
+            set opts(password) $::twapi::nullptr
+        }
+        IScheduledWorkItem_SetAccountInformation $itask $opts(account) $opts(password)
+    }
+
+    if {[info exists opts(idlewait)] || [info exists opts(idlewaitdeadline)]} {
+        # If either one is not specified, get the current settings
+        if {! ([info exists opts(idlewait)] &&
+               [info exists opts(idlewaitdeadline)]) } {
+            lassign [IScheduledWorkItem_GetIdleWait $itask] idle dead
+            if {![info exists opts(idlewait)]} {
+                set opts(idlewait) $idle
+            }
+            if {![info exists opts(idlewaitdeadline)]} {
+                set opts(idlewaitdeadline) $dead
+            }
+        }
+        IScheduledWorkItem_SetIdleWait $itask $opts(idlewait) $opts(idlewaitdeadline)
+    }
+
+    # Finally figure out and set the flags if needed
+    if {[info exists opts(interactive)] ||
+        [info exists opts(deletewhendone)] ||
+        [info exists opts(disabled)] ||
+        [info exists opts(hidden)] ||
+        [info exists opts(runonlyifloggedon)] ||
+        [info exists opts(startonlyifidle)] ||
+        [info exists opts(resumesystem)] ||
+        [info exists opts(killonidleend)] ||
+        [info exists opts(restartonidleresume)] ||
+        [info exists opts(dontstartonbatteries)] ||
+        [info exists opts(killifonbatteries)]} {
+
+        # First, get the current flags
+        set flags [IScheduledWorkItem_GetFlags $itask]
+        foreach {opt val} {
+            interactive         0x1
+            deletewhendone      0x2
+            disabled            0x4
+            startonlyifidle     0x10
+            hidden              0x200
+            runonlyifloggedon   0x2000
+            resumesystem        0x1000
+            killonidleend       0x20
+            restartonidleresume 0x800
+            dontstartonbatteries 0x40
+            killifonbatteries   0x80
+        } {
+            # Set / reset the bit if specified
+            if {[info exists opts($opt)]} {
+                if {$opts($opt)} {
+                    setbits flags $val
+                } else {
+                    resetbits flags $val
+                }
+            }
+        }
+
+        # Now set the new value of flags
+        IScheduledWorkItem_SetFlags $itask $flags
+    }
+
+
+    return
+}
+
+proc twapi::itask_get_info {itask args} {
+    # Note options errorretrycount and errorretryinterval are not implemented
+    # by the OS so left out
+    array set opts [parseargs args {
+        all
+        application
+        maxruntime
+        params
+        priority
+        workingdir
+        account
+        comment
+        creator
+        data
+        idlewait
+        idlewaitdeadline
+        interactive
+        deletewhendone
+        disabled
+        hidden
+        runonlyifloggedon
+        startonlyifidle
+        resumesystem
+        killonidleend
+        restartonidleresume
+        dontstartonbatteries
+        killifonbatteries
+        lastruntime
+        nextruntime
+        status
+    } -maxleftover 0]
+
+    set result [list ]
+    if {$opts(all) || $opts(priority)} {
+        switch -exact -- [twapi::ITask_GetPriority $itask] {
+            32    { set priority normal }
+            64    { set priority idle }
+            128   { set priority high }
+            256   { set priority realtime }
+            16384 { set priority belownormal }
+            32768 { set priority abovenormal }
+            default { set priority unknown }
+        }
+        lappend result -priority $priority
+    }
+
+    foreach {opt fn} {
+        application ITask_GetApplicationName
+        maxruntime  ITask_GetMaxRunTime
+        params      ITask_GetParameters
+        workingdir  ITask_GetWorkingDirectory
+        account            IScheduledWorkItem_GetAccountInformation
+        comment            IScheduledWorkItem_GetComment
+        creator            IScheduledWorkItem_GetCreator
+        data               IScheduledWorkItem_GetWorkItemData
+    } {
+        if {$opts(all) || $opts($opt)} {
+            trap {
+                lappend result -$opt [$fn  $itask]
+            } onerror {TWAPI_WIN32 -2147216625} {
+                # THe information is empty in the scheduler database
+                lappend result -$opt {}
+            }
+        }
+    }
+
+    if {$opts(all) || $opts(lastruntime)} {
+        trap {
+            lappend result -lastruntime [_timelist_to_timestring [IScheduledWorkItem_GetMostRecentRunTime $itask]]
+        } onerror {TWAPI_WIN32 267011} {
+            # Not run yet at all
+            lappend result -lastruntime {}
+        }
+    }
+
+    if {$opts(all) || $opts(nextruntime)} {
+        trap {
+            lappend result -nextruntime [_timelist_to_timestring [IScheduledWorkItem_GetNextRunTime $itask]]
+        } onerror {TWAPI_WIN32 267010} {
+            # Task is disabled
+            lappend result -nextruntime disabled
+        } onerror {TWAPI_WIN32 267015} {
+            # No triggers set
+            lappend result -nextruntime notriggers
+        } onerror {TWAPI_WIN32 267016} {
+            # No triggers set
+            lappend result -nextruntime oneventonly
+        }
+    }
+
+    if {$opts(all) || $opts(status)} {
+        set status [IScheduledWorkItem_GetStatus $itask]
+        if {$status == 0x41300} {
+            set status ready
+        } elseif {$status == 0x41301} {
+            set status running
+        } elseif {$status == 0x41302} {
+            set status disabled
+        } elseif {$status == 0x41305} {
+            set status partiallydefined
+        } else {
+            set status unknown
+        }
+        lappend result -status $status
+    }
+
+
+    if {$opts(all) || $opts(idlewait) || $opts(idlewaitdeadline)} {
+        lassign [IScheduledWorkItem_GetIdleWait $itask] idle dead
+        if {$opts(all) || $opts(idlewait)} {
+            lappend result -idlewait $idle
+        }
+        if {$opts(all) || $opts(idlewaitdeadline)} {
+            lappend result -idlewaitdeadline $dead
+        }
+    }
+
+    # Finally figure out and set the flags if needed
+    if {$opts(all) ||
+        $opts(interactive) ||
+        $opts(deletewhendone) ||
+        $opts(disabled) ||
+        $opts(hidden) ||
+        $opts(runonlyifloggedon) ||
+        $opts(startonlyifidle) ||
+        $opts(resumesystem) ||
+        $opts(killonidleend) ||
+        $opts(restartonidleresume) ||
+        $opts(dontstartonbatteries) ||
+        $opts(killifonbatteries)} {
+
+        # First, get the current flags
+        set flags [IScheduledWorkItem_GetFlags $itask]
+        foreach {opt val} {
+            interactive         0x1
+            deletewhendone      0x2
+            disabled            0x4
+            startonlyifidle     0x10
+            hidden              0x200
+            runonlyifloggedon   0x2000
+            resumesystem        0x1000
+            killonidleend       0x20
+            restartonidleresume 0x800
+            dontstartonbatteries 0x40
+            killifonbatteries   0x80
+        } {
+            if {$opts(all) || $opts($opt)} {
+                lappend result -$opt [expr {($flags & $val) ? true : false}]
+            }
+        }
+    }
+
+
+    return $result
+}
+
+# Get the runtimes for a task within an interval
+proc twapi::itask_get_runtimes_within_interval {itask args} {
+    array set opts [parseargs args {
+        start.arg
+        end.arg
+        {count.int 1}
+        statusvar.arg
+    } -maxleftover 0]
+
+    if {[info exists opts(start)]} {
+        set start [_timestring_to_timelist $opts(start)]
+    } else {
+        set start [_seconds_to_timelist [clock seconds]]
+    }
+    if {[info exists opts(end)]} {
+        set end [_timestring_to_timelist $opts(end)]
+    } else {
+        set end {2038 1 1 0 0 0 0}
+    }
+
+    set result [list ]
+    if {[info exists opts(statusvar)]} {
+        upvar $opts(statusvar) status
+    }
+    lassign [IScheduledWorkItem_GetRunTimes $itask $start $end $opts(count)] status timelist
+
+    foreach time $timelist {
+        lappend result [_timelist_to_timestring $time]
+    }
+
+
+    return $result
+}
+
+# Saves the specified ITask
+proc twapi::itask_save {itask} {
+    set ipersist [Twapi_IUnknown_QueryInterface $itask [name_to_iid IPersistFile] IPersistFile]
+    trap {
+        IPersistFile_Save $ipersist "" 1
+    } finally {
+        IUnknown_Release $ipersist
+    }
+    return
+}
+
+# Show property editor for a task
+proc twapi::itask_edit_dialog {itask args} {
+    array set opts [parseargs args {
+        {hwin.arg 0}
+    } -maxleftover 0]
+
+    return [twapi::IScheduledWorkItem_EditWorkItem $itask $opts(hwin) 0]
+}
+
+
+interp alias {} ::twapi::itask_release {} ::twapi::IUnknown_Release
+
+# Get information about a trigger
+proc twapi::itasktrigger_get_info {itt} {
+    array set data [ITaskTrigger_GetTrigger $itt]
+
+    set result(-begindate) [format %04d-%02d-%02d $data(wBeginYear) $data(wBeginMonth) $data(wBeginDay)]
+
+    set result(-starttime) [format %02d:%02d $data(wStartHour) $data(wStartMinute)]
+
+    if {$data(rgFlags) & 1} {
+        set result(-enddate) [format %04d-%02d-%02d $data(wEndYear) $data(wEndMonth) $data(wEndDay)]
+    } else {
+        set result(-enddate) ""
+    }
+
+    set result(-duration) $data(MinutesDuration)
+    set result(-interval) $data(MinutesInterval)
+    if {$data(rgFlags) & 2} {
+        set result(-killatdurationend) true
+    } else {
+        set result(-killatdurationend) false
+    }
+
+    if {$data(rgFlags) & 4} {
+        set result(-disabled) true
+    } else {
+        set result(-disabled) false
+    }
+
+    switch -exact -- [lindex $data(type) 0] {
+        0 {
+            set result(-type) once
+        }
+        1 {
+            set result(-type) daily
+            set result(-period) [lindex $data(type) 1]
+        }
+        2 {
+            set result(-type) weekly
+            set result(-period) [lindex $data(type) 1]
+            set result(-weekdays) [format 0x%x [lindex $data(type) 2]]
+        }
+        3 {
+            set result(-type) monthlydate
+            set result(-daysofmonth) [format 0x%x [lindex $data(type) 1]]
+            set result(-months) [format 0x%x [lindex $data(type) 2]]
+        }
+        4 {
+            set result(-type) monthlydow
+            set result(-weekofmonth) [lindex {first second third fourth last} [lindex $data(type) 2]]
+            set result(-weekdays) [format 0x%x [lindex $data(type) 2]]
+            set result(-months) [format 0x%x [lindex $data(type) 3]]
+        }
+        5 {
+            set result(-type) onidle
+        }
+        6 {
+            set result(-type) atsystemstart
+        }
+        7 {
+            set result(-type) atlogon
+        }
+    }
+    return [array get result]
+}
+
+
+# Configure a task trigger
+proc twapi::itasktrigger_configure {itt args} {
+    array set opts [parseargs args {
+        begindate.arg
+        enddate.arg
+        starttime.arg
+        interval.int
+        duration.int
+        killatdurationend.bool
+        disabled.bool
+        type.arg
+        weekofmonth.int
+        {period.int 1}
+        {weekdays.int 0x7f}
+        {daysofmonth.int 0x7fffffff}
+        {months.int 0xfff}
+    } -maxleftover 0]
+
+
+    array set data [ITaskTrigger_GetTrigger $itt]
+
+    if {[info exists opts(begindate)]} {
+        lassign  [split $opts(begindate) -]  year month day
+        # Note we trim leading zeroes else Tcl thinks its octal
+        set data(wBeginYear) [scan $year %d]
+        set data(wBeginMonth) [scan $month %d]
+        set data(wBeginDay) [scan $day %d]
+    }
+
+    if {[info exists opts(starttime)]} {
+        lassign [split $opts(starttime) :] hour minute
+        # Note we trim leading zeroes else Tcl thinks its octal
+        set data(wStartHour) [scan $hour %d]
+        set data(wStartMinute) [scan $minute %d]
+    }
+
+    if {[info exists opts(enddate)]} {
+        if {$opts(enddate) ne ""} {
+            setbits data(rgFlags) 1;        # Indicate end date is present
+            lassign  [split $opts(enddate) -] year month day
+            # Note we trim leading zeroes else Tcl thinks its octal
+            set data(wEndYear) [scan $year %d]
+            set data(wEndMonth) [scan $month %d]
+            set data(wEndDay) [scan $day %d]
+        } else {
+            resetbits data(rgFlags) 1;  # Indicate no end date
+        }
+    }
+
+
+    if {[info exists opts(duration)]} {
+        set data(MinutesDuration) $opts(duration)
+    }
+
+    if {[info exists opts(interval)]} {
+        set data(MinutesInterval) $opts(interval)
+    }
+
+    if {[info exists opts(killatdurationend)]} {
+        if {$opts(killatdurationend)} {
+            setbits data(rgFlags) 2
+        } else {
+            resetbits data(rgFlags) 2
+        }
+    }
+
+    if {[info exists opts(disabled)]} {
+        if {$opts(disabled)} {
+            setbits data(rgFlags) 4
+        } else {
+            resetbits data(rgFlags) 4
+        }
+    }
+
+    # Note the type specific options are only used if -type is specified
+    if {[info exists opts(type)]} {
+        switch -exact -- $opts(type) {
+            once {
+                set data(type) [list 0]
+            }
+            daily {
+                set data(type) [list 1 $opts(period)]
+            }
+            weekly {
+                set data(type) [list 2 $opts(period) $opts(weekdays)]
+            }
+            monthlydate {
+                set data(type) [list 3 $opts(daysofmonth) $opts(months)]
+            }
+            monthlydow {
+                set data(type) [list 4 $opts(weekofmonth) $opts(weekdays) $opts(months)]
+            }
+            onidle {
+                set data(type) [list 5]
+            }
+            atsystemstart {
+                set data(type) [list 6]
+            }
+            atlogon {
+                set data(type) [list 7]
+            }
+        }
+    }
+
+    ITaskTrigger_SetTrigger $itt [array get data]
+    return
+}
+
+interp alias {} ::twapi::itasktrigger_release {} ::twapi::IUnknown_Release
+
+# Create a new task from scratch. Basically a wrapper around the
+# corresponding itaskscheduler, itask and itasktrigger calls
+proc twapi::mstask_create {taskname args} {
+
+    # The options are a combination of itask_configure and
+    # itasktrigger_configure.
+    # Note the disabled option default to false explicitly. This is because
+    # the task trigger will default to disabled unless specifically set.
+    array set opts [parseargs args {
+        system.arg
+        application.arg
+        maxruntime.int
+        params.arg
+        priority.arg
+        workingdir.arg
+        account.arg
+        password.arg
+        comment.arg
+        creator.arg
+        data.arg
+        idlewait.int
+        idlewaitdeadline.int
+        interactive.bool
+        deletewhendone.bool
+        {disabled.bool false}
+        hidden.bool
+        runonlyifloggedon.bool
+        startonlyifidle.bool
+        resumesystem.bool
+        killonidleend.bool
+        restartonidleresume.bool
+        dontstartonbatteries.bool
+        killifonbatteries.bool
+        begindate.arg
+        enddate.arg
+        starttime.arg
+        interval.int
+        duration.int
+        killatdurationend.bool
+        type.arg
+        period.int
+        weekdays.int
+        daysofmonth.int
+        months.int
+    } -maxleftover 0]
+
+    set its [itaskscheduler_new]
+    trap {
+        if {[info exists opts(system)]} {
+            itaskscheduler_set_target_system $opts(system)
+        }
+
+        set itask [itaskscheduler_new_itask $its $taskname]
+        # Construct the command line for configuring the task
+        set cmd [list itask_configure $itask]
+        foreach opt {
+            application
+            maxruntime
+            params
+            priority
+            workingdir
+            account
+            password
+            comment
+            creator
+            data
+            idlewait
+            idlewaitdeadline
+            interactive
+            deletewhendone
+            disabled
+            hidden
+            runonlyifloggedon
+            startonlyifidle
+            resumesystem
+            killonidleend
+            restartonidleresume
+            dontstartonbatteries
+            killifonbatteries
+        } {
+            if {[info exists opts($opt)]} {
+                lappend cmd -$opt $opts($opt)
+            }
+        }
+        eval $cmd
+
+        # Now get a trigger and configure it
+        set itt [lindex [itask_new_itasktrigger $itask] 1]
+        set cmd [list itasktrigger_configure $itt]
+        foreach opt {
+            begindate
+            enddate
+            interval
+            starttime
+            duration
+            killatdurationend
+            type
+            period
+            weekdays
+            daysofmonth
+            months
+            disabled
+        } {
+            if {[info exists opts($opt)]} {
+                lappend cmd -$opt $opts($opt)
+            }
+        }
+        eval $cmd
+
+        # Save the task
+        itask_save $itask
+
+    } finally {
+        IUnknown_Release $its
+        if {[info exists itask]} {
+            IUnknown_Release $itask
+        }
+        if {[info exists itt]} {
+            IUnknown_Release $itt
+        }
+    }
+    return
+}
+
+# Delete a task
+proc twapi::mstask_delete {taskname args} {
+    # The options are a combination of itask_configure and
+    # itasktrigger_configure
+    array set opts [parseargs args {
+        system.arg
+    } -maxleftover 0]
+    set its [itaskscheduler_new]
+    trap {
+        if {[info exists opts(system)]} {
+            itaskscheduler_set_target_system $opts(system)
+        }
+        itaskscheduler_delete_task $its $taskname
+    } finally {
+        IUnknown_Release $its
+    }
+    return
+}

src/punk86.vfs/lib/twapi4.7.2/multimedia.tcl

@@ -0,0 +1,75 @@
+#
+# Copyright (c) 2012 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# Generate sound for the specified duration
+proc twapi::beep {args} {
+    array set opts [parseargs args {
+        {frequency.int 1000}
+        {duration.int 100}
+        {type.arg}
+    }]
+
+    if {[info exists opts(type)]} {
+        switch -exact -- $opts(type) {
+            ok           {MessageBeep 0}
+            hand         {MessageBeep 0x10}
+            question     {MessageBeep 0x20}
+            exclaimation {MessageBeep 0x30}
+            exclamation {MessageBeep 0x30}
+            asterisk     {MessageBeep 0x40}
+            default      {error "Unknown sound type '$opts(type)'"}
+        }
+        return
+    }
+    Beep $opts(frequency) $opts(duration)
+    return
+}
+
+# Play the specified sound
+proc twapi::play_sound {name args} {
+    array set opts [parseargs args {
+        alias
+        async
+        loop
+        nodefault
+        wait
+        nostop
+    }]
+
+    if {$opts(alias)} {
+        set flags 0x00010000; #SND_ALIAS
+    } else {
+        set flags 0x00020000; #SND_FILENAME
+    }
+    if {$opts(loop)} {
+        # Note LOOP requires ASYNC
+        setbits flags 0x9; #SND_LOOP | SND_ASYNC
+    } else {
+        if {$opts(async)} {
+            setbits flags 0x0001; #SND_ASYNC
+        } else {
+            setbits flags 0x0000; #SND_SYNC
+        }
+    }
+
+    if {$opts(nodefault)} {
+        setbits flags 0x0002; #SND_NODEFAULT
+    }
+
+    if {! $opts(wait)} {
+        setbits flags 0x00002000; #SND_NOWAIT
+    }
+
+    if {$opts(nostop)} {
+        setbits flags 0x0010; #SND_NOSTOP
+    }
+
+    return [PlaySound $name 0 $flags]
+}
+
+proc twapi::stop_sound {} {
+    PlaySound "" 0 0x0040; #SND_PURGE
+}

src/punk86.vfs/lib/twapi4.7.2/namedpipe.tcl

@@ -0,0 +1,103 @@
+#
+# Copyright (c) 2010-2011, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# Implementation of named pipes
+
+proc twapi::namedpipe_server {name args} {
+    set name [file nativename $name]
+
+    # Only byte mode currently supported. Message mode does
+    # not mesh well with Tcl channel infrastructure.
+    # readmode.arg
+    # writemode.arg
+
+    array set opts [twapi::parseargs args {
+        {access.arg {read write}}
+        {writedacl    0  0x00040000}
+        {writeowner   0  0x00080000}
+        {writesacl    0  0x01000000}
+        {writethrough 0  0x80000000}
+        denyremote
+        {timeout.int 50}
+        {maxinstances.int 255}
+        {secd.arg {}}
+        {inherit.bool 0}
+    } -maxleftover 0]
+
+    # 0x40000000 -> OVERLAPPED I/O
+    set open_mode [expr {
+                         [twapi::_parse_symbolic_bitmask $opts(access) {read 1 write 2}] |
+                         $opts(writedacl) | $opts(writeowner) |
+                         $opts(writesacl) | $opts(writethrough) |
+                         0x40000000
+                      }]
+        
+    set pipe_mode 0
+    if {$opts(denyremote)} {
+        if {! [twapi::min_os_version 6]} {
+            error "Option -denyremote not supported on this operating system."
+        }
+        set pipe_mode [expr {$pipe_mode | 8}]
+    }
+
+    return [twapi::Twapi_NPipeServer $name $open_mode $pipe_mode \
+                $opts(maxinstances) 4000 4000 $opts(timeout) \
+                [_make_secattr $opts(secd) $opts(inherit)]]
+}
+
+proc twapi::namedpipe_client {name args} {
+    set name [file nativename $name]
+
+    # Only byte mode currently supported. Message mode does
+    # not mesh well with Tcl channel infrastructure.
+    # readmode.arg
+    # writemode.arg
+
+    array set opts [twapi::parseargs args {
+        {access.arg {read write}}
+        impersonationlevel.arg
+        {impersonateeffectiveonly.bool false 0x00080000}
+        {impersonatecontexttracking.bool false 0x00040000}
+    } -maxleftover 0]
+
+    # FILE_READ_DATA              0x00000001
+    # FILE_WRITE_DATA             0x00000002
+    # Note - use _parse_symbolic_bitmask because we allow user to specify
+    # numeric masks as well
+    set desired_access [twapi::_parse_symbolic_bitmask $opts(access) {
+        read  1
+        write 2
+    }]
+        
+    set flags 0
+    if {[info exists opts(impersonationlevel)]} {
+        switch -exact -- $opts(impersonationlevel) {
+            anonymous      { set flags 0x00100000 }
+            identification { set flags 0x00110000 }
+            impersonation  { set flags 0x00120000 }
+            delegation     { set flags 0x00130000 }
+            default {
+                # ERROR_BAD_IMPERSONATION_LEVEL
+                win32_error 1346 "Invalid impersonation level '$opts(impersonationlevel)'."
+            }
+        }
+        set flags [expr {$flags | $opts(impersonateeffectiveonly) |
+                         $opts(impersonatecontexttracking)}]
+    }
+
+    set share_mode 0;           # Share none
+    set secattr {};             # At some point use this for "inherit" flag
+    set create_disposition 3;   # OPEN_EXISTING
+    return [twapi::Twapi_NPipeClient $name $desired_access $share_mode \
+                $secattr $create_disposition $flags]
+}
+
+# Impersonate a named pipe client
+proc twapi::impersonate_namedpipe_client {chan} {
+    set h [get_tcl_channel_handle $chan read]
+    ImpersonateNamedPipeClient $h
+}
+

src/punk86.vfs/lib/twapi4.7.2/nls.tcl

@@ -0,0 +1,467 @@
+#
+# Copyright (c) 2003-2013, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {}
+
+# Compatibility alias
+interp alias {} twapi::get_user_default_langid {} twapi::get_user_langid
+interp alias {} twapi::get_system_default_langid {} twapi::get_system_langid
+
+#
+# Format a number
+proc twapi::format_number {number lcid args} {
+
+    set number [_verify_number_format $number]
+
+    set lcid [_map_default_lcid_token $lcid]
+
+    # If no options specified, format according to the passed locale
+    if {[llength $args] == 0} {
+        return [GetNumberFormat 1 $lcid 0 $number 0 0 0 . "" 0]
+    }
+
+    array set opts [parseargs args {
+        idigits.int
+        ilzero.bool
+        sgrouping.int
+        sdecimal.arg
+        sthousand.arg
+        inegnumber.int
+    }]
+
+    # Check the locale for unspecified options
+    foreach opt {idigits ilzero sgrouping sdecimal sthousand inegnumber} {
+        if {![info exists opts($opt)]} {
+            set opts($opt) [lindex [get_locale_info $lcid -$opt] 1]
+        }
+    }
+        
+    # If number of decimals is -1, see how many decimal places
+    # in passed string
+    if {$opts(idigits) == -1} {
+        lassign   [split $number .]  whole frac
+        set opts(idigits) [string length $frac]
+    }
+
+    # Convert Locale format for grouping to integer calue
+    if {![string is integer $opts(sgrouping)]} {
+        # Format assumed to be of the form "N;M;....;0"
+        set grouping 0
+        foreach n [split $opts(sgrouping) {;}] {
+            if {$n == 0} break
+            set grouping [expr {$n + 10*$grouping}]
+        }
+        set opts(sgrouping) $grouping
+    }
+
+    set flags 0
+    if {[info exists opts(nouseroverride)] && $opts(nouseroverride)} {
+        setbits flags 0x80000000
+    }
+    return [GetNumberFormat 0 $lcid $flags $number $opts(idigits) \
+                $opts(ilzero) $opts(sgrouping) $opts(sdecimal) \
+                $opts(sthousand) $opts(inegnumber)]
+}
+
+
+#
+# Format currency
+proc twapi::format_currency {number lcid args} {
+
+    set number [_verify_number_format $number]
+
+    # Get semi-canonical form (get rid of preceding "+" etc.)
+    # Also verifies number syntax
+    set number [expr {$number+0}];
+
+    set lcid [_map_default_lcid_token $lcid]
+
+    # If no options specified, format according to the passed locale
+    if {[llength $args] == 0} {
+        return [GetCurrencyFormat 1 $lcid 0 $number 0 0 0 . "" 0 0 ""]
+    }
+
+    array set opts [parseargs args {
+        idigits.int
+        ilzero.bool
+        sgrouping.int
+        sdecimal.arg
+        sthousand.arg
+        inegcurr.int
+        icurrency.int
+        scurrency.arg
+    }]
+
+    # Check the locale for unspecified options
+    foreach opt {idigits ilzero sgrouping sdecimal sthousand inegcurr icurrency scurrency} {
+        if {![info exists opts($opt)]} {
+            set opts($opt) [lindex [get_locale_info $lcid -$opt] 1]
+        }
+    }
+
+    # If number of decimals is -1, see how many decimal places
+    # in passed string
+    if {$opts(idigits) == -1} {
+        lassign  [split $number .]  whole frac
+        set opts(idigits) [string length $frac]
+    }
+
+    # Convert Locale format for grouping to integer calue
+    if {![string is integer $opts(sgrouping)]} {
+        # Format assumed to be of the form "N;M;....;0"
+        set grouping 0
+        foreach n [split $opts(sgrouping) {;}] {
+            if {$n == 0} break
+            set grouping [expr {$n + 10*$grouping}]
+        }
+        set opts(sgrouping) $grouping
+    }
+
+    set flags 0
+    if {[info exists opts(nouseroverride)] && $opts(nouseroverride)} {
+        setbits flags 0x80000000
+    }
+
+    return [GetCurrencyFormat 0 $lcid $flags $number $opts(idigits) \
+                $opts(ilzero) $opts(sgrouping) $opts(sdecimal) \
+                $opts(sthousand) $opts(inegcurr) \
+                $opts(icurrency) $opts(scurrency)]
+}
+
+
+#
+# Get various info about a locale
+proc twapi::get_locale_info {lcid args} {
+
+    set lcid [_map_default_lcid_token $lcid]
+
+    variable locale_info_class_map
+    if {![info exists locale_info_class_map]} {
+        # TBD - ilanguage not recommended for Vista. Remove it?
+        array set locale_info_class_map {
+            ilanguage              0x00000001
+            slanguage              0x00000002
+            senglanguage           0x00001001
+            sabbrevlangname        0x00000003
+            snativelangname        0x00000004
+            icountry               0x00000005
+            scountry               0x00000006
+            sengcountry            0x00001002
+            sabbrevctryname        0x00000007
+            snativectryname        0x00000008
+            idefaultlanguage       0x00000009
+            idefaultcountry        0x0000000A
+            idefaultcodepage       0x0000000B
+            idefaultansicodepage   0x00001004
+            idefaultmaccodepage    0x00001011
+            slist                  0x0000000C
+            imeasure               0x0000000D
+            sdecimal               0x0000000E
+            sthousand              0x0000000F
+            sgrouping              0x00000010
+            idigits                0x00000011
+            ilzero                 0x00000012
+            inegnumber             0x00001010
+            snativedigits          0x00000013
+            scurrency              0x00000014
+            sintlsymbol            0x00000015
+            smondecimalsep         0x00000016
+            smonthousandsep        0x00000017
+            smongrouping           0x00000018
+            icurrdigits            0x00000019
+            iintlcurrdigits        0x0000001A
+            icurrency              0x0000001B
+            inegcurr               0x0000001C
+            sdate                  0x0000001D
+            stime                  0x0000001E
+            sshortdate             0x0000001F
+            slongdate              0x00000020
+            stimeformat            0x00001003
+            idate                  0x00000021
+            ildate                 0x00000022
+            itime                  0x00000023
+            itimemarkposn          0x00001005
+            icentury               0x00000024
+            itlzero                0x00000025
+            idaylzero              0x00000026
+            imonlzero              0x00000027
+            s1159                  0x00000028
+            s2359                  0x00000029
+            icalendartype          0x00001009
+            ioptionalcalendar      0x0000100B
+            ifirstdayofweek        0x0000100C
+            ifirstweekofyear       0x0000100D
+            sdayname1              0x0000002A
+            sdayname2              0x0000002B
+            sdayname3              0x0000002C
+            sdayname4              0x0000002D
+            sdayname5              0x0000002E
+            sdayname6              0x0000002F
+            sdayname7              0x00000030
+            sabbrevdayname1        0x00000031
+            sabbrevdayname2        0x00000032
+            sabbrevdayname3        0x00000033
+            sabbrevdayname4        0x00000034
+            sabbrevdayname5        0x00000035
+            sabbrevdayname6        0x00000036
+            sabbrevdayname7        0x00000037
+            smonthname1            0x00000038
+            smonthname2            0x00000039
+            smonthname3            0x0000003A
+            smonthname4            0x0000003B
+            smonthname5            0x0000003C
+            smonthname6            0x0000003D
+            smonthname7            0x0000003E
+            smonthname8            0x0000003F
+            smonthname9            0x00000040
+            smonthname10           0x00000041
+            smonthname11           0x00000042
+            smonthname12           0x00000043
+            smonthname13           0x0000100E
+            sabbrevmonthname1      0x00000044
+            sabbrevmonthname2      0x00000045
+            sabbrevmonthname3      0x00000046
+            sabbrevmonthname4      0x00000047
+            sabbrevmonthname5      0x00000048
+            sabbrevmonthname6      0x00000049
+            sabbrevmonthname7      0x0000004A
+            sabbrevmonthname8      0x0000004B
+            sabbrevmonthname9      0x0000004C
+            sabbrevmonthname10     0x0000004D
+            sabbrevmonthname11     0x0000004E
+            sabbrevmonthname12     0x0000004F
+            sabbrevmonthname13     0x0000100F
+            spositivesign          0x00000050
+            snegativesign          0x00000051
+            ipossignposn           0x00000052
+            inegsignposn           0x00000053
+            ipossymprecedes        0x00000054
+            ipossepbyspace         0x00000055
+            inegsymprecedes        0x00000056
+            inegsepbyspace         0x00000057
+            fontsignature          0x00000058
+            siso639langname        0x00000059
+            siso3166ctryname       0x0000005A
+            idefaultebcdiccodepage 0x00001012
+            ipapersize             0x0000100A
+            sengcurrname           0x00001007
+            snativecurrname        0x00001008
+            syearmonth             0x00001006
+            ssortname              0x00001013
+            idigitsubstitution     0x00001014
+        }
+    }
+
+    #    array set opts [parseargs args [array names locale_info_class_map]]
+
+    set result [list ]
+    foreach opt $args {
+        lappend result $opt [GetLocaleInfo $lcid $locale_info_class_map([string range $opt 1 end])]
+    }
+    return $result
+}
+
+
+proc twapi::map_code_page_to_name {cp} {
+    set code_page_names {
+        0   "System ANSI default"
+        1   "System OEM default"
+        37 "IBM EBCDIC - U.S./Canada"
+        437 "OEM - United States"
+        500 "IBM EBCDIC - International"
+        708 "Arabic - ASMO 708"
+        709 "Arabic - ASMO 449+, BCON V4"
+        710 "Arabic - Transparent Arabic"
+        720 "Arabic - Transparent ASMO"
+        737 "OEM - Greek (formerly 437G)"
+        775 "OEM - Baltic"
+        850 "OEM - Multilingual Latin I"
+        852 "OEM - Latin II"
+        855 "OEM - Cyrillic (primarily Russian)"
+        857 "OEM - Turkish"
+        858 "OEM - Multlingual Latin I + Euro symbol"
+        860 "OEM - Portuguese"
+        861 "OEM - Icelandic"
+        862 "OEM - Hebrew"
+        863 "OEM - Canadian-French"
+        864 "OEM - Arabic"
+        865 "OEM - Nordic"
+        866 "OEM - Russian"
+        869 "OEM - Modern Greek"
+        870 "IBM EBCDIC - Multilingual/ROECE (Latin-2)"
+        874 "ANSI/OEM - Thai (same as 28605, ISO 8859-15)"
+        875 "IBM EBCDIC - Modern Greek"
+        932 "ANSI/OEM - Japanese, Shift-JIS"
+        936 "ANSI/OEM - Simplified Chinese (PRC, Singapore)"
+        949 "ANSI/OEM - Korean (Unified Hangeul Code)"
+        950 "ANSI/OEM - Traditional Chinese (Taiwan; Hong Kong SAR, PRC)"
+        1026 "IBM EBCDIC - Turkish (Latin-5)"
+        1047 "IBM EBCDIC - Latin 1/Open System"
+        1140 "IBM EBCDIC - U.S./Canada (037 + Euro symbol)"
+        1141 "IBM EBCDIC - Germany (20273 + Euro symbol)"
+        1142 "IBM EBCDIC - Denmark/Norway (20277 + Euro symbol)"
+        1143 "IBM EBCDIC - Finland/Sweden (20278 + Euro symbol)"
+        1144 "IBM EBCDIC - Italy (20280 + Euro symbol)"
+        1145 "IBM EBCDIC - Latin America/Spain (20284 + Euro symbol)"
+        1146 "IBM EBCDIC - United Kingdom (20285 + Euro symbol)"
+        1147 "IBM EBCDIC - France (20297 + Euro symbol)"
+        1148 "IBM EBCDIC - International (500 + Euro symbol)"
+        1149 "IBM EBCDIC - Icelandic (20871 + Euro symbol)"
+        1200 "Unicode UCS-2 Little-Endian (BMP of ISO 10646)"
+        1201 "Unicode UCS-2 Big-Endian"
+        1250 "ANSI - Central European"
+        1251 "ANSI - Cyrillic"
+        1252 "ANSI - Latin I"
+        1253 "ANSI - Greek"
+        1254 "ANSI - Turkish"
+        1255 "ANSI - Hebrew"
+        1256 "ANSI - Arabic"
+        1257 "ANSI - Baltic"
+        1258 "ANSI/OEM - Vietnamese"
+        1361 "Korean (Johab)"
+        10000 "MAC - Roman"
+        10001 "MAC - Japanese"
+        10002 "MAC - Traditional Chinese (Big5)"
+        10003 "MAC - Korean"
+        10004 "MAC - Arabic"
+        10005 "MAC - Hebrew"
+        10006 "MAC - Greek I"
+        10007 "MAC - Cyrillic"
+        10008 "MAC - Simplified Chinese (GB 2312)"
+        10010 "MAC - Romania"
+        10017 "MAC - Ukraine"
+        10021 "MAC - Thai"
+        10029 "MAC - Latin II"
+        10079 "MAC - Icelandic"
+        10081 "MAC - Turkish"
+        10082 "MAC - Croatia"
+        12000 "Unicode UCS-4 Little-Endian"
+        12001 "Unicode UCS-4 Big-Endian"
+        20000 "CNS - Taiwan"
+        20001 "TCA - Taiwan"
+        20002 "Eten - Taiwan"
+        20003 "IBM5550 - Taiwan"
+        20004 "TeleText - Taiwan"
+        20005 "Wang - Taiwan"
+        20105 "IA5 IRV International Alphabet No. 5 (7-bit)"
+        20106 "IA5 German (7-bit)"
+        20107 "IA5 Swedish (7-bit)"
+        20108 "IA5 Norwegian (7-bit)"
+        20127 "US-ASCII (7-bit)"
+        20261 "T.61"
+        20269 "ISO 6937 Non-Spacing Accent"
+        20273 "IBM EBCDIC - Germany"
+        20277 "IBM EBCDIC - Denmark/Norway"
+        20278 "IBM EBCDIC - Finland/Sweden"
+        20280 "IBM EBCDIC - Italy"
+        20284 "IBM EBCDIC - Latin America/Spain"
+        20285 "IBM EBCDIC - United Kingdom"
+        20290 "IBM EBCDIC - Japanese Katakana Extended"
+        20297 "IBM EBCDIC - France"
+        20420 "IBM EBCDIC - Arabic"
+        20423 "IBM EBCDIC - Greek"
+        20424 "IBM EBCDIC - Hebrew"
+        20833 "IBM EBCDIC - Korean Extended"
+        20838 "IBM EBCDIC - Thai"
+        20866 "Russian - KOI8-R"
+        20871 "IBM EBCDIC - Icelandic"
+        20880 "IBM EBCDIC - Cyrillic (Russian)"
+        20905 "IBM EBCDIC - Turkish"
+        20924 "IBM EBCDIC - Latin-1/Open System (1047 + Euro symbol)"
+        20932 "JIS X 0208-1990 & 0121-1990"
+        20936 "Simplified Chinese (GB2312)"
+        21025 "IBM EBCDIC - Cyrillic (Serbian, Bulgarian)"
+        21027 "Extended Alpha Lowercase"
+        21866 "Ukrainian (KOI8-U)"
+        28591 "ISO 8859-1 Latin I"
+        28592 "ISO 8859-2 Central Europe"
+        28593 "ISO 8859-3 Latin 3"
+        28594 "ISO 8859-4 Baltic"
+        28595 "ISO 8859-5 Cyrillic"
+        28596 "ISO 8859-6 Arabic"
+        28597 "ISO 8859-7 Greek"
+        28598 "ISO 8859-8 Hebrew"
+        28599 "ISO 8859-9 Latin 5"
+        28605 "ISO 8859-15 Latin 9"
+        29001 "Europa 3"
+        38598 "ISO 8859-8 Hebrew"
+        50220 "ISO 2022 Japanese with no halfwidth Katakana"
+        50221 "ISO 2022 Japanese with halfwidth Katakana"
+        50222 "ISO 2022 Japanese JIS X 0201-1989"
+        50225 "ISO 2022 Korean"
+        50227 "ISO 2022 Simplified Chinese"
+        50229 "ISO 2022 Traditional Chinese"
+        50930 "Japanese (Katakana) Extended"
+        50931 "US/Canada and Japanese"
+        50933 "Korean Extended and Korean"
+        50935 "Simplified Chinese Extended and Simplified Chinese"
+        50936 "Simplified Chinese"
+        50937 "US/Canada and Traditional Chinese"
+        50939 "Japanese (Latin) Extended and Japanese"
+        51932 "EUC - Japanese"
+        51936 "EUC - Simplified Chinese"
+        51949 "EUC - Korean"
+        51950 "EUC - Traditional Chinese"
+        52936 "HZ-GB2312 Simplified Chinese"
+        54936 "Windows XP: GB18030 Simplified Chinese (4 Byte)"
+        57002 "ISCII Devanagari"
+        57003 "ISCII Bengali"
+        57004 "ISCII Tamil"
+        57005 "ISCII Telugu"
+        57006 "ISCII Assamese"
+        57007 "ISCII Oriya"
+        57008 "ISCII Kannada"
+        57009 "ISCII Malayalam"
+        57010 "ISCII Gujarati"
+        57011 "ISCII Punjabi"
+        65000 "Unicode UTF-7"
+        65001 "Unicode UTF-8"
+    }
+
+    # TBD - isn't there a Win32 function to do this ?
+    set cp [expr {0+$cp}]
+    if {[dict exists $code_page_names $cp]} {
+        return [dict get $code_page_names $cp]
+    } else {
+        return "Code page $cp"
+    }
+}
+
+#
+# Get the name of a language
+interp alias {} twapi::map_langid_to_name {} twapi::VerLanguageName
+
+#
+# Extract language and sublanguage values
+proc twapi::extract_primary_langid {langid} {
+    return [expr {$langid & 0x3ff}]
+}
+proc twapi::extract_sublanguage_langid {langid} {
+    return [expr {($langid >> 10) & 0x3f}]
+}
+
+#
+# Utility functions
+
+proc twapi::_map_default_lcid_token {lcid} {
+    if {$lcid == "systemdefault"} {
+        return 2048
+    } elseif {$lcid == "userdefault"} {
+        return 1024
+    }
+    return $lcid
+}
+
+proc twapi::_verify_number_format {n} {
+    set n [string trimleft $n 0]
+    if {[regexp {^[+-]?[[:digit:]]*(\.)?[[:digit:]]*$} $n]} {
+        return $n
+    } else {
+        error "Invalid numeric format. Must be of a sequence of digits with an optional decimal point and leading plus/minus sign"
+    }
+}
+
+

src/punk86.vfs/lib/twapi4.7.2/pdh.tcl

@@ -0,0 +1,984 @@
+#
+# Copyright (c) 2003-2014, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {
+}
+
+#
+# Return list of toplevel performance objects
+proc twapi::pdh_enumerate_objects {args} {
+
+    array set opts [parseargs args {
+        datasource.arg
+        machine.arg
+        {detail.arg wizard}
+        refresh
+    } -nulldefault]
+    
+    # TBD - PdhEnumObjects enables the SeDebugPrivilege the first time it
+    # is called. Should we reset it if it was not already enabled?
+    # This seems to only happen on the first call
+
+    return [PdhEnumObjects $opts(datasource) $opts(machine) \
+                [_perf_detail_sym_to_val $opts(detail)] \
+                $opts(refresh)]
+}
+
+proc twapi::_pdh_enumerate_object_items_helper {selector objname args} {
+    array set opts [parseargs args {
+        datasource.arg
+        machine.arg
+        {detail.arg wizard}
+        refresh
+    } -nulldefault]
+    
+    if {$opts(refresh)} {
+        _refresh_perf_objects $opts(machine) $opts(datasource)
+    }
+
+    return [PdhEnumObjectItems $opts(datasource) $opts(machine) \
+                $objname \
+                [_perf_detail_sym_to_val $opts(detail)] \
+                $selector]
+}
+
+interp alias {} twapi::pdh_enumerate_object_items {} twapi::_pdh_enumerate_object_items_helper 0
+interp alias {} twapi::pdh_enumerate_object_counters {} twapi::_pdh_enumerate_object_items_helper 1
+interp alias {} twapi::pdh_enumerate_object_instances {} twapi::_pdh_enumerate_object_items_helper 2
+
+
+#
+# Construct a counter path
+proc twapi::pdh_counter_path {object counter args} {
+    array set opts [parseargs args {
+        machine.arg
+        instance.arg
+        parent.arg
+        {instanceindex.int -1}
+        {localized.bool false}
+    } -nulldefault]
+    
+    if {$opts(instanceindex) == 0} {
+        # For XP. For first instance (index 0), the path should not contain
+        # "#0" but on XP it does. Reset it to -1 for Vista+ consistency
+        set opts(instanceindex) -1
+    }
+
+
+    if {! $opts(localized)} {
+        # Need to localize the counter names
+        set object [_pdh_localize $object]
+        set counter [_pdh_localize $counter]
+        # TBD - not sure we need to localize parent
+        set opts(parent) [_pdh_localize $opts(parent)]
+    }
+
+    # TBD - add options PDH_PATH_WBEM as documented in PdhMakeCounterPath
+    return [PdhMakeCounterPath $opts(machine) $object $opts(instance) \
+                $opts(parent) $opts(instanceindex) $counter 0]
+
+}
+
+#
+# Parse a counter path and return the individual elements
+proc twapi::pdh_parse_counter_path {counter_path} {
+    return [twine {machine object instance parent instanceindex counter} [PdhParseCounterPath $counter_path 0]]
+}
+
+
+interp alias {} twapi::pdh_get_scalar {} twapi::_pdh_get 1
+interp alias {} twapi::pdh_get_array {} twapi::_pdh_get 0
+
+proc twapi::_pdh_get {scalar hcounter args} {
+
+    array set opts [parseargs args {
+        {format.arg large {long large double}}
+        {scale.arg {} {{} none x1000 nocap100}}
+        var.arg
+    } -ignoreunknown -nulldefault]
+    
+    set flags [_pdh_fmt_sym_to_val $opts(format)]
+
+    if {$opts(scale) ne ""} {
+        set flags [expr {$flags | [_pdh_fmt_sym_to_val $opts(scale)]}]
+    }
+
+    set status 1
+    set result ""
+    trap {
+        if {$scalar} {
+            set result [PdhGetFormattedCounterValue $hcounter $flags]
+        } else {
+            set result [PdhGetFormattedCounterArray $hcounter $flags]
+        }
+    } onerror {TWAPI_WIN32 0x800007d1} {
+        # Error is that no such instance exists.
+        # If result is being returned in a variable, then
+        # we will not generate an error but pass back a return value
+        # of 0
+        if {[string length $opts(var)] == 0} {
+            rethrow
+        }
+        set status 0
+    }
+    
+    if {[string length $opts(var)]} {
+        uplevel [list set $opts(var) $result]
+        return $status
+    } else {
+        return $result
+    }
+}
+
+#
+# Get the value of a counter identified by the path.
+# Should not be used to collect
+# rate based options.
+# TBD - document
+proc twapi::pdh_counter_path_value {counter_path args} {
+
+    array set opts [parseargs args {
+        {format.arg long}
+        scale.arg
+        datasource.arg
+        var.arg
+        full.bool
+    } -nulldefault]
+    
+    # Open the query
+    set hquery [pdh_query_open -datasource $opts(datasource)]
+    trap {
+        set hcounter [pdh_add_counter $hquery $counter_path]
+        pdh_query_refresh $hquery
+        if {[string length $opts(var)]} {
+            # Need to pass up value in a variable if so requested
+            upvar $opts(var) myvar
+            set opts(var) myvar
+        }
+        set value [pdh_get_scalar $hcounter -format $opts(format) \
+                       -scale $opts(scale) -full $opts(full) \
+                       -var $opts(var)]
+    } finally {
+        pdh_query_close $hquery
+    }
+
+    return $value
+}
+
+
+#
+# Constructs one or more counter paths for getting process information. 
+# Returned as a list of sublists. Each sublist corresponds to a counter path 
+# and has the form {counteroptionname datatype counterpath rate}
+# datatype is the recommended format when retrieving counter value (eg. double)
+# rate is 0 or 1 depending on whether the counter is a rate based counter or 
+# not (requires at least two readings when getting the value)
+proc twapi::get_perf_process_counter_paths {pids args} {
+    variable _process_counter_opt_map
+
+    if {![info exists _counter_opt_map]} {
+        #  "descriptive string" format rate
+        array set _process_counter_opt_map {
+            privilegedutilization {"% Privileged Time"   double 1}
+            processorutilization  {"% Processor Time"    double 1}
+            userutilization       {"% User Time"         double 1}
+            parent                {"Creating Process ID" long   0}
+            elapsedtime           {"Elapsed Time"        large  0}
+            handlecount           {"Handle Count"        long   0}
+            pid                   {"ID Process"          long   0}
+            iodatabytesrate       {"IO Data Bytes/sec"   large  1}
+            iodataopsrate         {"IO Data Operations/sec"  large 1}
+            iootherbytesrate      {"IO Other Bytes/sec"      large 1}
+            iootheropsrate        {"IO Other Operations/sec" large 1}
+            ioreadbytesrate       {"IO Read Bytes/sec"       large 1}
+            ioreadopsrate         {"IO Read Operations/sec"  large 1}
+            iowritebytesrate      {"IO Write Bytes/sec"      large 1}
+            iowriteopsrate        {"IO Write Operations/sec" large 1}
+            pagefaultrate         {"Page Faults/sec"         large 1}
+            pagefilebytes         {"Page File Bytes"         large 0}
+            pagefilebytespeak     {"Page File Bytes Peak"    large 0}
+            poolnonpagedbytes     {"Pool Nonpaged Bytes"     large 0}
+            poolpagedbytes        {"Pool Paged Bytes"        large 1}
+            basepriority          {"Priority Base"           large 1}
+            privatebytes          {"Private Bytes"           large 1}
+            threadcount           {"Thread Count"            large 1}
+            virtualbytes          {"Virtual Bytes"           large 1}
+            virtualbytespeak      {"Virtual Bytes Peak"      large 1}
+            workingset            {"Working Set"             large 1}
+            workingsetpeak        {"Working Set Peak"        large 1}
+        }
+    }
+
+    set optdefs {
+        machine.arg
+        datasource.arg
+        all
+        refresh
+    }
+
+    # Add counter names to option list
+    foreach cntr [array names _process_counter_opt_map] {
+        lappend optdefs $cntr
+    }
+
+    # Parse options
+    array set opts [parseargs args $optdefs -nulldefault]
+
+    # Force a refresh of object items
+    if {$opts(refresh)} {
+        # Silently ignore. The above counters are predefined and refreshing
+        # is just a time-consuming no-op. Keep the option for backward
+        # compatibility
+        if {0} {
+            _refresh_perf_objects $opts(machine) $opts(datasource)
+        }
+    }
+
+    # TBD - could we not use get_perf_instance_counter_paths instead of rest of this code
+
+    # Get the path to the process.
+    set pid_paths [get_perf_counter_paths \
+                       [_pdh_localize "Process"] \
+                       [list [_pdh_localize "ID Process"]] \
+                       $pids \
+                       -machine $opts(machine) -datasource $opts(datasource) \
+                       -all]
+
+    if {[llength $pid_paths] == 0} {
+        # No thread
+        return [list ]
+    }
+
+    # Construct the requested counter paths
+    set counter_paths [list ]
+    foreach {pid pid_path} $pid_paths {
+
+        # We have to filter out an entry for _Total which might be present
+        # if pid includes "0"
+        # TBD - does _Total need to be localized?
+        if {$pid == 0 && [string match -nocase *_Total\#0* $pid_path]} {
+            continue
+        }
+
+        # Break it down into components and store in array
+        array set path_components [pdh_parse_counter_path $pid_path]
+
+        # Construct counter paths for this pid
+        foreach {opt counter_info} [array get _process_counter_opt_map] {
+            if {$opts(all) || $opts($opt)} {
+                lappend counter_paths \
+                    [list -$opt $pid [lindex $counter_info 1] \
+                         [pdh_counter_path $path_components(object) \
+                              [_pdh_localize [lindex $counter_info 0]] \
+                              -localized true \
+                              -machine $path_components(machine) \
+                              -parent $path_components(parent) \
+                              -instance $path_components(instance) \
+                              -instanceindex $path_components(instanceindex)] \
+                         [lindex $counter_info 2] \
+                        ]
+            }
+        }                        
+    }
+
+    return $counter_paths
+}
+
+
+# Returns the counter path for the process with the given pid. This includes
+# the pid counter path element
+proc twapi::get_perf_process_id_path {pid args} {
+    return [get_unique_counter_path \
+                [_pdh_localize "Process"] \
+                [_pdh_localize "ID Process"] $pid]
+}
+
+
+#
+# Constructs one or more counter paths for getting thread information. 
+# Returned as a list of sublists. Each sublist corresponds to a counter path 
+# and has the form {counteroptionname datatype counterpath rate}
+# datatype is the recommended format when retrieving counter value (eg. double)
+# rate is 0 or 1 depending on whether the counter is a rate based counter or 
+# not (requires at least two readings when getting the value)
+proc twapi::get_perf_thread_counter_paths {tids args} {
+    variable _thread_counter_opt_map
+
+    if {![info exists _thread_counter_opt_map]} {
+        array set _thread_counter_opt_map {
+            privilegedutilization {"% Privileged Time"       double 1}
+            processorutilization  {"% Processor Time"        double 1}
+            userutilization       {"% User Time"             double 1}
+            contextswitchrate     {"Context Switches/sec"    long 1}
+            elapsedtime           {"Elapsed Time"            large 0}
+            pid                   {"ID Process"              long 0}
+            tid                   {"ID Thread"               long 0}
+            basepriority          {"Priority Base"           long 0}
+            priority              {"Priority Current"        long 0}
+            startaddress          {"Start Address"           large 0}
+            state                 {"Thread State"            long 0}
+            waitreason            {"Thread Wait Reason"      long 0}
+        }
+    }
+
+    set optdefs {
+        machine.arg
+        datasource.arg
+        all
+        refresh
+    }
+
+    # Add counter names to option list
+    foreach cntr [array names _thread_counter_opt_map] {
+        lappend optdefs $cntr
+    }
+
+    # Parse options
+    array set opts [parseargs args $optdefs -nulldefault]
+
+    # Force a refresh of object items
+    if {$opts(refresh)} {
+        # Silently ignore. The above counters are predefined and refreshing
+        # is just a time-consuming no-op. Keep the option for backward
+        # compatibility
+        if {0} {
+            _refresh_perf_objects $opts(machine) $opts(datasource)
+        }
+    }
+
+    # TBD - could we not use get_perf_instance_counter_paths instead of rest of this code
+
+    # Get the path to the thread
+    set tid_paths [get_perf_counter_paths \
+                       [_pdh_localize "Thread"] \
+                       [list [_pdh_localize "ID Thread"]] \
+                       $tids \
+                      -machine $opts(machine) -datasource $opts(datasource) \
+                      -all]
+    
+    if {[llength $tid_paths] == 0} {
+        # No thread
+        return [list ]
+    }
+
+    # Now construct the requested counter paths
+    set counter_paths [list ]
+    foreach {tid tid_path} $tid_paths {
+        # Break it down into components and store in array
+        array set path_components [pdh_parse_counter_path $tid_path]
+        foreach {opt counter_info} [array get _thread_counter_opt_map] {
+            if {$opts(all) || $opts($opt)} {
+                lappend counter_paths \
+                    [list -$opt $tid [lindex $counter_info 1] \
+                         [pdh_counter_path $path_components(object) \
+                              [_pdh_localize [lindex $counter_info 0]] \
+                              -localized true \
+                              -machine $path_components(machine) \
+                              -parent $path_components(parent) \
+                              -instance $path_components(instance) \
+                              -instanceindex $path_components(instanceindex)] \
+                         [lindex $counter_info 2]
+                    ]
+            }
+        }                            
+    }
+
+    return $counter_paths
+}
+
+
+# Returns the counter path for the thread with the given tid. This includes
+# the tid counter path element
+proc twapi::get_perf_thread_id_path {tid args} {
+
+    return [get_unique_counter_path [_pdh_localize"Thread"] [_pdh_localize "ID Thread"] $tid]
+}
+
+
+#
+# Constructs one or more counter paths for getting processor information. 
+# Returned as a list of sublists. Each sublist corresponds to a counter path 
+# and has the form {counteroptionname datatype counterpath rate}
+# datatype is the recommended format when retrieving counter value (eg. double)
+# rate is 0 or 1 depending on whether the counter is a rate based counter or 
+# not (requires at least two readings when getting the value)
+# $processor should be the processor number or "" to get total
+proc twapi::get_perf_processor_counter_paths {processor args} {
+    variable _processor_counter_opt_map
+
+    if {![string is integer -strict $processor]} {
+        if {[string length $processor]} {
+            error "Processor id must be an integer or null to retrieve information for all processors"
+        }
+        set processor "_Total"
+    }
+
+    if {![info exists _processor_counter_opt_map]} {
+        array set _processor_counter_opt_map {
+            dpcutilization        {"% DPC Time"              double 1}
+            interruptutilization  {"% Interrupt Time"        double 1}
+            privilegedutilization {"% Privileged Time"       double 1}
+            processorutilization  {"% Processor Time"        double 1}
+            userutilization       {"% User Time"             double 1}
+            dpcrate               {"DPC Rate"                double 1}
+            dpcqueuerate          {"DPCs Queued/sec"         double 1}
+            interruptrate         {"Interrupts/sec"          double 1}
+        }
+    }
+
+    set optdefs {
+        machine.arg
+        datasource.arg
+        all
+        refresh
+    }
+
+    # Add counter names to option list
+    foreach cntr [array names _processor_counter_opt_map] {
+        lappend optdefs $cntr
+    }
+
+    # Parse options
+    array set opts [parseargs args $optdefs -nulldefault -maxleftover 0]
+
+    # Force a refresh of object items
+    if {$opts(refresh)} {
+        # Silently ignore. The above counters are predefined and refreshing
+        # is just a time-consuming no-op. Keep the option for backward
+        # compatibility
+        if {0} {
+            _refresh_perf_objects $opts(machine) $opts(datasource)
+        }
+    }
+
+    # Now construct the requested counter paths
+    set counter_paths [list ]
+    foreach {opt counter_info} [array get _processor_counter_opt_map] {
+        if {$opts(all) || $opts($opt)} {
+            lappend counter_paths \
+                [list $opt $processor [lindex $counter_info 1] \
+                     [pdh_counter_path \
+                          [_pdh_localize "Processor"] \
+                          [_pdh_localize [lindex $counter_info 0]] \
+                          -localized true \
+                          -machine $opts(machine) \
+                          -instance $processor] \
+                     [lindex $counter_info 2] \
+                    ]
+        }
+    }
+
+    return $counter_paths
+}
+
+
+
+#
+# Returns a list comprising of the counter paths for counters with
+# names in the list $counters from those instance(s) whose counter
+# $key_counter matches the specified $key_counter_value
+proc twapi::get_perf_instance_counter_paths {object counters
+                                             key_counter key_counter_values
+                                             args} {
+    # Parse options
+    array set opts [parseargs args {
+        machine.arg
+        datasource.arg
+        {matchop.arg "exact"}
+        skiptotal.bool
+        refresh
+    } -nulldefault]
+
+    # Force a refresh of object items
+    if {$opts(refresh)} {
+        _refresh_perf_objects $opts(machine) $opts(datasource)
+    }
+
+    # Get the list of instances that have the specified value for the
+    # key counter
+    set instance_paths [get_perf_counter_paths $object \
+                            [list $key_counter] $key_counter_values \
+                            -machine $opts(machine) \
+                            -datasource $opts(datasource) \
+                            -matchop $opts(matchop) \
+                            -skiptotal $opts(skiptotal) \
+                            -all]
+
+    # Loop through all instance paths, and all counters to generate 
+    # We store in an array to get rid of duplicates
+    array set counter_paths {}
+    foreach {key_counter_value instance_path} $instance_paths {
+        # Break it down into components and store in array
+        array set path_components [pdh_parse_counter_path $instance_path]
+
+        # Now construct the requested counter paths
+        # TBD - what should -localized be here ?
+        foreach counter $counters {
+            set counter_path \
+                [pdh_counter_path $path_components(object) \
+                     $counter \
+                     -localized true \
+                     -machine $path_components(machine) \
+                     -parent $path_components(parent) \
+                     -instance $path_components(instance) \
+                     -instanceindex $path_components(instanceindex)]
+            set counter_paths($counter_path) ""
+        }                            
+    }
+
+    return [array names counter_paths]
+
+
+}
+
+
+#
+# Returns a list comprising of the counter paths for all counters
+# whose values match the specified criteria
+proc twapi::get_perf_counter_paths {object counters counter_values args} {
+    array set opts [parseargs args {
+        machine.arg
+        datasource.arg
+        {matchop.arg "exact"}
+        skiptotal.bool
+        all
+        refresh
+    } -nulldefault]
+
+    if {$opts(refresh)} {
+        _refresh_perf_objects $opts(machine) $opts(datasource)
+    }
+
+    set items [pdh_enum_object_items $object \
+                   -machine $opts(machine) \
+                   -datasource $opts(datasource)]
+    lassign $items object_counters object_instances
+
+    if {[llength $counters]} {
+        set object_counters $counters
+    }
+    set paths [_make_counter_path_list \
+                   $object $object_instances $object_counters \
+                   -skiptotal $opts(skiptotal) -machine $opts(machine)]
+    set result_paths [list ]
+    trap {
+        # Set up the query with the process id for all processes
+        set hquery [pdh_query_open -datasource $opts(datasource)]
+        foreach path $paths {
+            set hcounter [pdh_add_counter $hquery $path]
+            set lookup($hcounter) $path
+        }
+
+        # Now collect the info
+        pdh_query_refresh $hquery
+        
+        # Now lookup each counter value to find a matching one
+        foreach hcounter [array names lookup] {
+            if {! [pdh_get_scalar $hcounter -var value]} {
+                # Counter or instance no longer exists
+                continue
+            }
+
+            set match_pos [lsearch -$opts(matchop) $counter_values $value]
+            if {$match_pos >= 0} {
+                lappend result_paths \
+                    [lindex $counter_values $match_pos] $lookup($hcounter)
+                if {! $opts(all)} {
+                    break
+                }
+            }
+        }
+    } finally {
+        # TBD - should we have a catch to throw errors?
+        pdh_query_close $hquery
+    }
+
+    return $result_paths
+}
+
+
+#
+# Returns the counter path for counter $counter with a value $value
+# for object $object. Returns "" on no matches but exception if more than one
+proc twapi::get_unique_counter_path {object counter value args} {
+    set matches [get_perf_counter_paths $object [list $counter ] [list $value] {*}$args -all]
+    if {[llength $matches] > 1} {
+        error "Multiple counter paths found matching criteria object='$object' counter='$counter' value='$value"
+    }
+    return [lindex $matches 0]
+}
+
+
+
+#
+# Utilities
+# 
+proc twapi::_refresh_perf_objects {machine datasource} {
+    pdh_enumerate_objects -refresh
+    return
+}
+
+
+#
+# Return the localized form of a counter name
+# TBD - assumes machine is local machine!
+proc twapi::_pdh_localize {name} {
+    variable _perf_counter_ids
+    variable _localized_perf_counter_names
+    
+    set name_index [string tolower $name]
+
+    # If we already have a translation, return it
+    if {[info exists _localized_perf_counter_names($name_index)]} {
+        return $_localized_perf_counter_names($name_index)
+    }
+
+    # Didn't already have it. Go generate the mappings
+
+    # Get the list of counter names in English if we don't already have it
+    if {![info exists _perf_counter_ids]} {
+        foreach {id label} [registry get {HKEY_PERFORMANCE_DATA} {Counter 009}] {
+            set _perf_counter_ids([string tolower $label]) $id
+        }
+    }
+
+    # If we have do not have id for the given name, we will just use
+    # the passed name as the localized version
+    if {! [info exists _perf_counter_ids($name_index)]} {
+        # Does not seem to exist. Just set localized name to itself
+        return [set _localized_perf_counter_names($name_index) $name]
+    }
+
+    # We do have an id. THen try to get a translated name
+    if {[catch {PdhLookupPerfNameByIndex "" $_perf_counter_ids($name_index)} xname]} {
+        set _localized_perf_counter_names($name_index) $name
+    } else {
+        set _localized_perf_counter_names($name_index) $xname
+    }
+
+    return $_localized_perf_counter_names($name_index)
+}
+
+
+# Given a list of instances and counters, return a cross product of the 
+# corresponding counter paths.
+# The list is expected to be already localized
+# Example: _make_counter_path_list "Process" (instance list) {{ID Process} {...}}
+# TBD - bug - does not handle -parent in counter path
+proc twapi::_make_counter_path_list {object instance_list counter_list args} {
+    array set opts [parseargs args {
+        machine.arg
+        skiptotal.bool
+    } -nulldefault]
+
+    array set instances {}
+    foreach instance $instance_list {
+        if {![info exists instances($instance)]} {
+            set instances($instance) 1
+        } else {
+            incr instances($instance)
+        }
+    }
+
+    if {$opts(skiptotal)} {
+        catch {array unset instances "*_Total"}
+    }
+
+    set counter_paths [list ]
+    foreach {instance count} [array get instances] {
+        while {$count} {
+            incr count -1
+            foreach counter $counter_list {
+                lappend counter_paths [pdh_counter_path \
+                                           $object $counter \
+                                           -localized true \
+                                           -machine $opts(machine) \
+                                           -instance $instance \
+                                           -instanceindex $count]
+            }
+        }
+    }
+
+    return $counter_paths
+}
+
+
+#
+# Given a set of counter paths in the format returned by 
+# get_perf_thread_counter_paths, get_perf_processor_counter_paths etc.
+# return the counter information as a flat list of field value pairs
+proc twapi::get_perf_values_from_metacounter_info {metacounters args} {
+    array set opts [parseargs args {{interval.int 100}}]
+
+    set result [list ]
+    set counters [list ]
+    if {[llength $metacounters]} {
+        set hquery [pdh_query_open]
+        trap {
+            set counter_info [list ]
+            set need_wait 0
+            foreach counter_elem $metacounters {
+                lassign $counter_elem pdh_opt key data_type counter_path wait
+                incr need_wait $wait
+                set hcounter [pdh_add_counter $hquery $counter_path]
+                lappend counters $hcounter
+                lappend counter_info $pdh_opt $key $counter_path $data_type $hcounter
+            }
+            
+            pdh_query_refresh $hquery
+            if {$need_wait} {
+                after $opts(interval)
+                pdh_query_refresh $hquery
+            }
+            
+            foreach {pdh_opt key counter_path data_type hcounter} $counter_info {
+                if {[pdh_get_scalar $hcounter -format $data_type -var value]} {
+                    lappend result $pdh_opt $key $value
+                }
+            }
+        } onerror {} {
+            #puts "Error: $msg"
+        } finally {
+            pdh_query_close $hquery
+        }
+    }
+
+    return $result
+
+}
+
+proc twapi::pdh_query_open {args} {
+    variable _pdh_queries
+
+    array set opts [parseargs args {
+        datasource.arg
+        cookie.int
+    } -nulldefault]
+
+    set qh [PdhOpenQuery $opts(datasource) $opts(cookie)]
+    set id pdh[TwapiId]
+    dict set _pdh_queries($id) Qh $qh
+    dict set _pdh_queries($id) Counters {}
+    dict set _pdh_queries($id) Meta {}
+    return $id
+}
+
+proc twapi::pdh_query_refresh {qid args} {
+    variable _pdh_queries
+    _pdh_query_check $qid
+    PdhCollectQueryData [dict get $_pdh_queries($qid) Qh]
+    return
+}
+
+proc twapi::pdh_query_close {qid} {
+    variable _pdh_queries
+    _pdh_query_check $qid
+
+    dict for {ctrh -} [dict get $_pdh_queries($qid) Counters] {
+        PdhRemoveCounter $ctrh
+    }
+
+    PdhCloseQuery [dict get $_pdh_queries($qid) Qh]
+    unset _pdh_queries($qid)
+}
+
+proc twapi::pdh_add_counter {qid ctr_path args} {
+    variable _pdh_queries
+
+    _pdh_query_check $qid
+
+    parseargs args {
+        {format.arg large {long large double}}
+        {scale.arg {} {{} none x1000 nocap100}}
+        name.arg
+        cookie.int
+        array.bool
+    } -nulldefault -maxleftover 0 -setvars
+    
+    if {$name eq ""} {
+        set name $ctr_path
+    }
+
+    if {[dict exists $_pdh_queries($qid) Meta $name]} {
+        error "A counter with name \"$name\" already present in the query."
+    }
+
+    set flags [_pdh_fmt_sym_to_val $format]
+
+    if {$scale ne ""} {
+        set flags [expr {$flags | [_pdh_fmt_sym_to_val $scale]}]
+    }
+
+    set hctr [PdhAddCounter [dict get $_pdh_queries($qid) Qh] $ctr_path $flags]
+    dict set _pdh_queries($qid) Counters $hctr 1
+    dict set _pdh_queries($qid) Meta $name [list Counter $hctr FmtFlags $flags Array $array]
+
+    return $hctr
+}
+
+proc twapi::pdh_remove_counter {qid ctrname} {
+    variable _pdh_queries
+    _pdh_query_check $qid
+    if {![dict exists $_pdh_queries($qid) Meta $ctrname]} {
+        badargs! "Counter \"$ctrname\" not present in query."
+    }
+    set hctr [dict get $_pdh_queries($qid) Meta $ctrname Counter]
+    dict unset _pdh_queries($qid) Counters $hctr
+    dict unset _pdh_queries($qid) Meta $ctrname
+    PdhRemoveCounter $hctr
+    return
+}
+
+proc twapi::pdh_query_get {qid args} {
+    variable _pdh_queries
+
+    _pdh_query_check $qid
+
+    # Refresh the data
+    PdhCollectQueryData [dict get $_pdh_queries($qid) Qh]
+
+    set meta [dict get $_pdh_queries($qid) Meta]
+
+    if {[llength $args] != 0} {
+        set names $args
+    } else {
+        set names [dict keys $meta]
+    }        
+
+    set result {}
+    foreach name $names {
+        if {[dict get $meta $name Array]} {
+		lappend result $name [PdhGetFormattedCounterArray [dict get $meta $name Counter] [dict get $meta $name FmtFlags]]
+	} else {
+		lappend result $name [PdhGetFormattedCounterValue [dict get $meta $name Counter] [dict get $meta $name FmtFlags]]
+	}
+    }
+
+    return $result
+}
+
+twapi::proc* twapi::pdh_system_performance_query args {
+    variable _sysperf_defs
+
+    set _sysperf_defs {
+        event_count { {Objects Events} {} }
+        mutex_count { {Objects Mutexes} {} }
+        process_count { {Objects Processes} {} }
+        section_count { {Objects Sections} {} }
+        semaphore_count { {Objects Semaphores} {} }
+        thread_count { {Objects Threads} {} }
+        handle_count { {Process "Handle Count" -instance _Total} {-format long} }
+        commit_limit { {Memory "Commit Limit"} {} }
+        committed_bytes { {Memory "Committed Bytes"} {} }
+        committed_percent { {Memory "% Committed Bytes In Use"} {-format double} }
+        memory_free_mb { {Memory "Available MBytes"} {} }
+        memory_free_kb { {Memory "Available KBytes"} {} }
+        page_fault_rate { {Memory "Page Faults/sec"} {} }
+        page_input_rate { {Memory "Pages Input/sec"} {} }
+        page_output_rate { {Memory "Pages Output/sec"} {} }
+
+        disk_bytes_rate { {PhysicalDisk "Disk Bytes/sec" -instance _Total} {} }
+        disk_readbytes_rate { {PhysicalDisk "Disk Read Bytes/sec" -instance _Total} {} }
+        disk_writebytes_rate { {PhysicalDisk "Disk Write Bytes/sec" -instance _Total} {} }
+        disk_transfer_rate { {PhysicalDisk "Disk Transfers/sec" -instance _Total} {} }
+        disk_read_rate { {PhysicalDisk "Disk Reads/sec" -instance _Total} {} }
+        disk_write_rate { {PhysicalDisk "Disk Writes/sec" -instance _Total} {} }
+        disk_idle_percent { {PhysicalDisk "% Idle Time" -instance _Total} {-format double} }
+    }
+
+    # Per-processor counters are based on above but the object name depends
+    # on the system in order to support > 64 processors
+    set obj_name [expr {[min_os_version 6 1] ? "Processor Information" : "Processor"}]
+    dict for {key ctr_name} {
+        interrupt_utilization "% Interrupt Time"
+        privileged_utilization "% Privileged Time"
+        processor_utilization  "% Processor Time"
+        user_utilization "% User Time"
+        idle_utilization "% Idle Time"
+    } {
+        lappend _sysperf_defs $key \
+            [list \
+                 [list $obj_name $ctr_name -instance _Total] \
+                 [list -format double]]
+
+        lappend _sysperf_defs ${key}_per_cpu \
+            [list \
+                 [list $obj_name $ctr_name -instance *] \
+                 [list -format double -array 1]]
+    }
+} {
+    variable _sysperf_defs
+
+    if {[llength $args] == 0} {
+        return [lsort -dictionary [dict keys $_sysperf_defs]]
+    }
+
+    set qid [pdh_query_open]
+    trap {
+        foreach arg $args {
+            set def [dict! $_sysperf_defs $arg]
+            set ctr_path [pdh_counter_path {*}[lindex $def 0]]
+            pdh_add_counter $qid $ctr_path -name $arg {*}[lindex $def 1]
+        }
+        pdh_query_refresh $qid
+    } onerror {} {
+        pdh_query_close $qid
+        rethrow
+    }
+
+    return $qid
+}
+
+#
+# Internal utility procedures
+proc twapi::_pdh_query_check {qid} {
+    variable _pdh_queries 
+
+    if {![info exists _pdh_queries($qid)]} {
+        error "Invalid query id $qid"
+    }
+}
+
+proc twapi::_perf_detail_sym_to_val {sym} {
+    # PERF_DETAIL_NOVICE          100
+    # PERF_DETAIL_ADVANCED        200
+    # PERF_DETAIL_EXPERT          300
+    # PERF_DETAIL_WIZARD          400
+    # PERF_DETAIL_COSTLY   0x00010000
+    # PERF_DETAIL_STANDARD 0x0000FFFF
+
+    return [dict get {novice 100 advanced 200 expert 300 wizard 400 costly 0x00010000 standard 0x0000ffff } $sym]
+}
+
+
+proc twapi::_pdh_fmt_sym_to_val {sym} {
+    # PDH_FMT_RAW     0x00000010
+    # PDH_FMT_ANSI    0x00000020
+    # PDH_FMT_UNICODE 0x00000040
+    # PDH_FMT_LONG    0x00000100
+    # PDH_FMT_DOUBLE  0x00000200
+    # PDH_FMT_LARGE   0x00000400
+    # PDH_FMT_NOSCALE 0x00001000
+    # PDH_FMT_1000    0x00002000
+    # PDH_FMT_NODATA  0x00004000
+    # PDH_FMT_NOCAP100 0x00008000
+
+    return [dict get {
+        raw     0x00000010
+        ansi    0x00000020
+        unicode 0x00000040
+        long    0x00000100
+        double  0x00000200
+        large   0x00000400
+        noscale 0x00001000
+        none    0x00001000
+        1000     0x00002000
+        x1000    0x00002000
+        nodata  0x00004000
+        nocap100 0x00008000
+        nocap 0x00008000
+    } $sym]
+}

src/punk86.vfs/lib/twapi4.7.2/pkgIndex.tcl

@@ -0,0 +1,119 @@
+#
+# Tcl package index file
+#
+
+namespace eval twapi {
+    variable scriptdir
+    proc set_scriptdir dir {variable scriptdir ; set scriptdir $dir}
+}
+
+package ifneeded twapi_base 4.7.2 \
+  [list load [file join $dir twapi472.dll] twapi_base]
+package ifneeded twapi_com 4.7.2 \
+  {load {} twapi_com}
+package ifneeded metoo 4.7.2 \
+  [list source [file join $dir metoo.tcl]]
+package ifneeded twapi_com 4.7.2 \
+  {load {} twapi_com}
+package ifneeded twapi_msi 4.7.2 \
+  [list source [file join $dir msi.tcl]]
+package ifneeded twapi_power 4.7.2 \
+  [list source [file join $dir power.tcl]]
+package ifneeded twapi_printer 4.7.2 \
+  [list source [file join $dir printer.tcl]]
+package ifneeded twapi_synch 4.7.2 \
+  [list source [file join $dir synch.tcl]]
+package ifneeded twapi_security 4.7.2 \
+  {load {} twapi_security}
+package ifneeded twapi_account 4.7.2 \
+  {load {} twapi_account}
+package ifneeded twapi_apputil 4.7.2 \
+  {load {} twapi_apputil}
+package ifneeded twapi_clipboard 4.7.2 \
+  {load {} twapi_clipboard}
+package ifneeded twapi_console 4.7.2 \
+  {load {} twapi_console}
+package ifneeded twapi_crypto 4.7.2 \
+  {load {} twapi_crypto}
+package ifneeded twapi_device 4.7.2 \
+  {load {} twapi_device}
+package ifneeded twapi_etw 4.7.2 \
+  {load {} twapi_etw}
+package ifneeded twapi_eventlog 4.7.2 \
+  {load {} twapi_eventlog}
+package ifneeded twapi_mstask 4.7.2 \
+  {load {} twapi_mstask}
+package ifneeded twapi_multimedia 4.7.2 \
+  {load {} twapi_multimedia}
+package ifneeded twapi_namedpipe 4.7.2 \
+  {load {} twapi_namedpipe}
+package ifneeded twapi_network 4.7.2 \
+  {load {} twapi_network}
+package ifneeded twapi_nls 4.7.2 \
+  {load {} twapi_nls}
+package ifneeded twapi_os 4.7.2 \
+  {load {} twapi_os}
+package ifneeded twapi_pdh 4.7.2 \
+  {load {} twapi_pdh}
+package ifneeded twapi_process 4.7.2 \
+  {load {} twapi_process}
+package ifneeded twapi_rds 4.7.2 \
+  {load {} twapi_rds}
+package ifneeded twapi_resource 4.7.2 \
+  {load {} twapi_resource}
+package ifneeded twapi_service 4.7.2 \
+  {load {} twapi_service}
+package ifneeded twapi_share 4.7.2 \
+  {load {} twapi_share}
+package ifneeded twapi_shell 4.7.2 \
+  {load {} twapi_shell}
+package ifneeded twapi_storage 4.7.2 \
+  {load {} twapi_storage}
+package ifneeded twapi_ui 4.7.2 \
+  {load {} twapi_ui}
+package ifneeded twapi_input 4.7.2 \
+  {load {} twapi_input}
+package ifneeded twapi_winsta 4.7.2 \
+  {load {} twapi_winsta}
+package ifneeded twapi_wmi 4.7.2 \
+  {load {} twapi_wmi}
+
+package ifneeded twapi 4.7.2 [subst {
+  twapi::set_scriptdir [list $dir]
+  package require twapi_base 4.7.2
+  source [list [file join $dir twapi_entry.tcl]]
+  package require metoo 4.7.2
+  package require twapi_com 4.7.2
+  package require twapi_msi 4.7.2
+  package require twapi_power 4.7.2
+  package require twapi_printer 4.7.2
+  package require twapi_synch 4.7.2
+  package require twapi_security 4.7.2
+  package require twapi_account 4.7.2
+  package require twapi_apputil 4.7.2
+  package require twapi_clipboard 4.7.2
+  package require twapi_console 4.7.2
+  package require twapi_crypto 4.7.2
+  package require twapi_device 4.7.2
+  package require twapi_etw 4.7.2
+  package require twapi_eventlog 4.7.2
+  package require twapi_mstask 4.7.2
+  package require twapi_multimedia 4.7.2
+  package require twapi_namedpipe 4.7.2
+  package require twapi_network 4.7.2
+  package require twapi_nls 4.7.2
+  package require twapi_os 4.7.2
+  package require twapi_pdh 4.7.2
+  package require twapi_process 4.7.2
+  package require twapi_rds 4.7.2
+  package require twapi_resource 4.7.2
+  package require twapi_service 4.7.2
+  package require twapi_share 4.7.2
+  package require twapi_shell 4.7.2
+  package require twapi_storage 4.7.2
+  package require twapi_ui 4.7.2
+  package require twapi_input 4.7.2
+  package require twapi_winsta 4.7.2
+  package require twapi_wmi 4.7.2
+  package provide twapi 4.7.2
+}]

src/punk86.vfs/lib/twapi4.7.2/power.tcl

@@ -0,0 +1,136 @@
+#
+# Copyright (c) 2003-2012 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {
+    variable _power_monitors
+    set _power_monitors [dict create]
+}
+
+# Get the power status of the system
+proc twapi::get_power_status {} {
+    lassign  [GetSystemPowerStatus] ac battery lifepercent reserved lifetime fulllifetime
+
+    set acstatus unknown
+    if {$ac == 0} {
+        set acstatus off
+    } elseif {$ac == 1} {
+        # Note only value 1 is "on", not just any non-0 value
+        set acstatus on
+    }
+
+    set batterycharging unknown
+    if {$battery == -1} {
+        set batterystate unknown
+    } elseif {$battery & 128} {
+        set batterystate notpresent;  # No battery
+    } else {
+        if {$battery & 8} {
+            set batterycharging true
+        } else {
+            set batterycharging false
+        }
+        if {$battery & 4} {
+            set batterystate critical
+        } elseif {$battery & 2} {
+            set batterystate low
+        } else {
+            set batterystate high
+        }
+    }
+
+    set batterylifepercent unknown
+    if {$lifepercent >= 0 && $lifepercent <= 100} {
+        set batterylifepercent $lifepercent
+    }
+
+    set batterylifetime $lifetime
+    if {$lifetime == -1} {
+        set batterylifetime unknown
+    }
+
+    set batteryfulllifetime $fulllifetime
+    if {$fulllifetime == -1} {
+        set batteryfulllifetime unknown
+    }
+
+    return [kl_create2 {
+        -acstatus
+        -batterystate
+        -batterycharging
+        -batterylifepercent
+        -batterylifetime
+        -batteryfulllifetime
+    } [list $acstatus $batterystate $batterycharging $batterylifepercent $batterylifetime $batteryfulllifetime]]
+}
+
+
+# Power notification callback
+proc twapi::_power_handler {msg power_event lparam msgpos ticks} {
+    variable _power_monitors
+
+    if {[dict size $_power_monitors] == 0} {
+        return; # Not an error, could have deleted while already queued
+    }
+
+    if {![kl_vget {
+        0 apmquerysuspend
+        2 apmquerysuspendfailed
+        4 apmsuspend
+        6 apmresumecritical
+        7 apmresumesuspend
+        9 apmbatterylow
+        10 apmpowerstatuschange
+        11 apmoemevent
+        18 apmresumeautomatic
+    } $power_event power_event]} {
+        return;                 # Do not support this event
+    }
+
+    dict for {id script} $_power_monitors {
+        set code [catch {uplevel #0 [linsert $script end $power_event $lparam]} msg]
+        if {$code == 1} {
+            # Error - put in background but we do not abort
+            after 0 [list error $msg $::errorInfo $::errorCode]
+        }
+    }
+    return
+}
+
+proc twapi::start_power_monitor {script} {
+    variable _power_monitors
+
+    set script [lrange $script 0 end]; # Verify syntactically a list
+
+    set id "power#[TwapiId]"
+    if {[dict size $_power_monitors] == 0} {
+        # No power monitoring in progress. Start it
+        # 0x218 -> WM_POWERBROADCAST
+        _register_script_wm_handler 0x218 [list [namespace current]::_power_handler] 1
+    }
+
+    dict set  _power_monitors $id $script
+    return $id
+}
+
+
+# Stop monitoring of the power
+proc twapi::stop_power_monitor {id} {
+    variable _power_monitors
+
+    if {![dict exists $_power_monitors $id]} {
+        return
+    }
+
+    dict unset _power_monitors $id
+    if {[dict size $_power_monitors] == 0} {
+        _unregister_script_wm_handler 0x218 [list [namespace current]::_power_handler]
+    }
+}
+
+# Hack to work with the various build configuration.
+if {[info commands ::twapi::get_version] ne ""} {
+    package provide twapi_power [::twapi::get_version -patchlevel]
+}

src/punk86.vfs/lib/twapi4.7.2/printer.tcl

@@ -0,0 +1,58 @@
+#
+# Copyright (c) 2004-2006 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {}
+
+proc twapi::enumerate_printers {args} {
+    array set opts [parseargs args {
+        {proximity.arg all {local remote all any}}
+    } -maxleftover 0]
+
+    set result [list ]
+    foreach elem [Twapi_EnumPrinters_Level4 \
+                      [string map {all 6 any 6 local 2 remote 4} $opts(proximity)] \
+                     ] {
+        lappend result [list [lindex $elem 0] [lindex $elem 1] \
+                            [_symbolize_printer_attributes [lindex $elem 2]]]
+    }
+    return [list {-name -server -attrs} $result]
+}
+
+
+# Utilities
+# 
+proc twapi::_symbolize_printer_attributes {attr} {
+    return [_make_symbolic_bitmask $attr {
+        queued         0x00000001
+        direct         0x00000002
+        default        0x00000004
+        shared         0x00000008
+        network        0x00000010
+        hidden         0x00000020
+        local          0x00000040
+        enabledevq      0x00000080
+        keepprintedjobs 0x00000100
+        docompletefirst 0x00000200
+        workoffline    0x00000400
+        enablebidi     0x00000800
+        rawonly        0x00001000
+        published      0x00002000
+        fax            0x00004000
+        ts             0x00008000
+        pusheduser     0x00020000
+        pushedmachine  0x00040000
+        machine        0x00080000
+        friendlyname   0x00100000
+        tsgenericdriver 0x00200000
+        peruser        0x00400000
+        enterprisecloud 0x00800000
+    }]
+}
+
+# Hack to work with the various build configuration.
+if {[info commands ::twapi::get_version] ne ""} {
+    package provide twapi_printer [::twapi::get_version -patchlevel]
+}

src/punk86.vfs/lib/twapi4.7.2/rds.tcl

@@ -0,0 +1,191 @@
+#
+# Copyright (c) 2010, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# Remote Desktop Services - TBD - document and test
+
+namespace eval twapi {}
+
+proc twapi::rds_enumerate_sessions {args} {
+    array set opts [parseargs args {
+        {hserver.arg 0}
+        state.arg
+    } -maxleftover 0]
+
+    set states {active connected connectquery shadow disconnected idle listen reset down init}
+    if {[info exists opts(state)]} {
+        if {[string is integer -strict $opts(state)]} {
+            set state $opts(state)
+        } else {
+            set state [lsearch -exact $states $opts(state)]
+            if {$state < 0} {
+                error "Invalid value '$opts(state)' specified for -state option."
+            }
+        }
+    }
+
+    set sessions [WTSEnumerateSessions $opts(hserver)]
+
+    if {[info exists state]} {
+        set sessions [recordarray get $sessions -filter [list [list State == $state]]]
+    }
+
+    set result {}
+    foreach {sess rec} [recordarray getdict $sessions -key SessionId -format dict] {
+        set state [lindex $states [kl_get $rec State]]
+        if {$state eq ""} {
+            set state [kl_get $rec State]
+        }
+        lappend result $sess [list -tssession [kl_get $rec SessionId] \
+                                  -winstaname [kl_get $rec pWinStationName] \
+                                  -state $state]
+    }
+    return $result
+}
+
+proc twapi::rds_disconnect_session args {
+    array set opts [parseargs args {
+        {hserver.arg 0}
+        {tssession.int -1}
+        {async.bool false}
+    } -maxleftover 0]
+
+    WTSDisconnectSession $opts(hserver) $opts(tssession) [expr {! $opts(async)}]
+
+}
+
+proc twapi::rds_logoff_session args {
+    array set opts [parseargs args {
+        {hserver.arg 0}
+        {tssession.int -1}
+        {async.bool false}
+    } -maxleftover 0]
+
+    WTSLogoffSession $opts(hserver) $opts(tssession) [expr {! $opts(async)}]
+}
+
+proc twapi::rds_query_session_information {infoclass args} {
+    array set opts [parseargs args {
+        {hserver.arg 0}
+        {tssession.int -1}
+    } -maxleftover 0]
+
+    return [WTSQuerySessionInformation $opts(hserver) $opts(tssession) $infoclass]
+}
+
+interp alias {} twapi::rds_get_session_appname {} twapi::rds_query_session_information 1
+interp alias {} twapi::rds_get_session_clientdir {} twapi::rds_query_session_information 11
+interp alias {} twapi::rds_get_session_clientname {} twapi::rds_query_session_information 10
+interp alias {} twapi::rds_get_session_userdomain {} twapi::rds_query_session_information 7
+interp alias {} twapi::rds_get_session_initialprogram {} twapi::rds_query_session_information 0
+interp alias {} twapi::rds_get_session_oemid {} twapi::rds_query_session_information 3
+interp alias {} twapi::rds_get_session_user {} twapi::rds_query_session_information 5
+interp alias {} twapi::rds_get_session_winsta {} twapi::rds_query_session_information 6
+interp alias {} twapi::rds_get_session_intialdir {} twapi::rds_query_session_information 2
+interp alias {} twapi::rds_get_session_clientbuild {} twapi::rds_query_session_information 9
+interp alias {} twapi::rds_get_session_clienthwid {} twapi::rds_query_session_information 13
+interp alias {} twapi::rds_get_session_state {} twapi::rds_query_session_information 8
+interp alias {} twapi::rds_get_session_id {} twapi::rds_query_session_information 4
+interp alias {} twapi::rds_get_session_productid {} twapi::rds_query_session_information 12
+interp alias {} twapi::rds_get_session_protocol {} twapi::rds_query_session_information 16
+
+
+proc twapi::rds_send_message {args} {
+
+    array set opts [parseargs args {
+        {hserver.arg 0}
+        tssession.int
+        title.arg
+        message.arg
+        {buttons.arg ok}
+        {icon.arg information}
+        defaultbutton.arg
+        {modality.arg task {task appl application system}}
+        {justify.arg left {left right}}
+        rtl.bool
+        foreground.bool
+        topmost.bool
+        showhelp.bool
+        service.bool
+        timeout.int
+        async.bool
+    } -maxleftover 0 -nulldefault]
+
+    if {![kl_vget {
+        ok             {0 {ok}}
+        okcancel       {1 {ok cancel}}
+        abortretryignore {2 {abort retry ignore}}
+        yesnocancel    {3 {yes no cancel}}
+        yesno          {4 {yes no}}
+        retrycancel    {5 {retry cancel}}
+        canceltrycontinue {6 {cancel try continue}}
+    } $opts(buttons) buttons]} {
+        error "Invalid value '$opts(buttons)' specified for option -buttons."
+    }
+
+    set style [lindex $buttons 0]
+    switch -exact -- $opts(icon) {
+        warning -
+        exclamation {setbits style 0x30}
+        asterisk -
+        information {setbits style 0x40}
+        question    {setbits style 0x20}
+        error -
+        hand  -
+        stop        {setbits style 0x10}
+        default {
+            error "Invalid value '$opts(icon)' specified for option -icon."
+        }
+    }
+
+    # Map the default button
+    switch -exact -- [lsearch -exact [lindex $buttons 1] $opts(defaultbutton)] {
+        1 {setbits style 0x100 }
+        2 {setbits style 0x200 }
+        3 {setbits style 0x300 }
+        default {
+            # First button,
+            # setbits style 0x000
+        }
+    }
+
+    switch -exact -- $opts(modality) {
+        system { setbits style 0x1000 }
+        task   { setbits style 0x2000 }
+        appl -
+        application -
+        default {
+            # setbits style 0x0000
+        }
+    }
+
+    if {$opts(showhelp)} { setbits style 0x00004000 }
+    if {$opts(rtl)} { setbits style 0x00100000 }
+    if {$opts(justify) eq "right"} { setbits style 0x00080000 }
+    if {$opts(topmost)} { setbits style 0x00040000 }
+    if {$opts(foreground)} { setbits style 0x00010000 }
+    if {$opts(service)} { setbits style 0x00200000 }
+
+    set response [WTSSendMessage $opts(hserver) $opts(tssession) $opts(title) \
+                      $opts(message) $style $opts(timeout) \
+                      [expr {!$opts(async)}]]
+    
+    switch -exact -- $response {
+        1 { return ok }
+        2 { return cancel }
+        3 { return abort }
+        4 { return retry }
+        5 { return ignore }
+        6 { return yes }
+        7 { return no }
+        8 { return close }
+        9 { return help }
+        10 { return tryagain }
+        11 { return continue }
+        32000 { return timeout }
+        32001 { return async }
+        default { return $response }
+    }
+}

src/punk86.vfs/lib/twapi4.7.2/registry.tcl

@@ -0,0 +1,490 @@
+#
+# Copyright (c) 2020 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {}
+
+#
+# TBD -32bit and -64bit options are not documented
+# pending test cases
+
+proc twapi::reg_key_copy {hkey to_hkey args} {
+    parseargs args {
+        subkey.arg
+        copysecd.bool
+    } -setvars -maxleftover 0 -nulldefault
+
+    if {$copysecd} {
+        RegCopyTree $hkey $subkey $to_hkey
+    } else {
+        SHCopyKey $hkey $subkey $to_hkey
+    }
+}
+
+proc twapi::reg_key_create {hkey subkey args} {
+    # TBD - document -link
+    # [opt_def [cmd -link] [arg BOOL]] If [const true], [arg SUBKEY] is stored as the
+    # value of the [const SymbolicLinkValue] value under [arg HKEY]. Default is
+    # [const false].
+    parseargs args {
+        {access.arg generic_read}
+        {inherit.bool 0}
+        {secd.arg ""}
+        {volatile.bool 0 0x1}
+        {link.bool 0 0x2}
+        {backup.bool 0 0x4}
+        32bit
+        64bit
+        disposition.arg
+    } -maxleftover 0 -setvars
+
+    set access [_access_rights_to_mask $access]
+    # Note: Following might be set via -access as well. The -32bit and -64bit
+    # options just make it a little more convenient for caller
+    if {$32bit} {
+        set access [expr {$access | 0x200}]
+    }
+    if {$64bit} {
+        set access [expr {$access | 0x100}]
+    }
+    lassign [RegCreateKeyEx \
+                 $hkey \
+                 $subkey \
+                 0 \
+                 "" \
+                 [expr {$volatile | $backup}] \
+                 $access \
+                 [_make_secattr $secd $inherit] \
+                ] hkey disposition_value
+    if {[info exists disposition]} {
+        upvar 1 $disposition created_or_existed
+        if {$disposition_value == 1} {
+            set created_or_existed created
+        } else {
+            # disposition_value == 2
+            set created_or_existed existed
+        }
+    }
+    return $hkey
+}
+
+proc twapi::reg_key_delete {hkey subkey args} {
+    parseargs args {
+        32bit
+        64bit
+    } -maxleftover 0 -setvars
+
+    # TBD - document options after adding tests
+    set access 0
+    if {$32bit} {
+        set access [expr {$access | 0x200}]
+    }
+    if {$64bit} {
+        set access [expr {$access | 0x100}]
+    }
+
+    RegDeleteKeyEx $hkey $subkey $access
+}
+
+proc twapi::reg_keys {hkey {subkey {}}} {
+    if {$subkey ne ""} {
+        set hkey [reg_key_open $hkey $subkey]
+    }
+    try {
+        return [RegEnumKeyEx $hkey 0]
+    } finally {
+        if {$subkey ne ""} {
+            reg_key_close $hkey
+        }
+    }
+}
+
+proc twapi::reg_key_open {hkey subkey args} {
+    # Not documented: -link, -32bit, -64bit
+    # [opt_def [cmd -link] [arg BOOL]] If [const true], specifies the key is a
+    # symbolic link. Defaults to [const false].
+    parseargs args {
+        {link.bool 0}
+        {access.arg generic_read}
+        32bit
+        64bit
+    } -maxleftover 0 -setvars
+
+    set access [_access_rights_to_mask $access]
+    # Note: Following might be set via -access as well. The -32bit and -64bit
+    # options just make it a little more convenient for caller
+    if {$32bit} {
+        set access [expr {$access | 0x200}]
+    }
+    if {$64bit} {
+        set access [expr {$access | 0x100}]
+    }
+    return [RegOpenKeyEx $hkey $subkey $link $access]
+}
+
+proc twapi::reg_value_delete {hkey args} {
+    if {[llength $args] == 1} {
+        RegDeleteValue $hkey [lindex $args 0]
+    } elseif {[llength $args] == 2} {
+        RegDeleteKeyValue $hkey {*}$args
+    } else {
+        error "Wrong # args: should be \"reg_value_delete ?SUBKEY? VALUENAME\""
+    }
+}
+
+proc twapi::reg_key_current_user {args} {
+    parseargs args {
+        {access.arg generic_read}
+        32bit
+        64bit
+    } -maxleftover 0 -setvars
+
+    set access [_access_rights_to_mask $access]
+    # Note: Following might be set via -access as well. The -32bit and -64bit
+    # options just make it a little more convenient for caller
+    if {$32bit} {
+        set access [expr {$access | 0x200}]
+    }
+    if {$64bit} {
+        set access [expr {$access | 0x100}]
+    }
+    return [RegOpenCurrentUser $access]
+}
+
+proc twapi::reg_key_user_classes_root {usertoken args} {
+    parseargs args {
+        {access.arg generic_read}
+        32bit
+        64bit
+    } -maxleftover 0 -setvars
+
+    set access [_access_rights_to_mask $access]
+    # Note: Following might be set via -access as well. The -32bit and -64bit
+    # options just make it a little more convenient for caller
+    if {$32bit} {
+        set access [expr {$access | 0x200}]
+    }
+    if {$64bit} {
+        set access [expr {$access | 0x100}]
+    }
+    return [RegOpenUserClassesRoot $usertoken 0 $access]
+}
+
+proc twapi::reg_key_export {hkey filepath args} {
+    parseargs args {
+        {secd.arg {}}
+        {format.arg xp {win2k xp}}
+        {compress.bool 1}
+    } -setvars
+
+    set format [dict get {win2k 1 xp 2} $format]
+    if {! $compress} {
+        set format [expr {$format | 4}]
+    }
+    twapi::eval_with_privileges {
+        RegSaveKeyEx $hkey $filepath [_make_secattr $secd 0] $format
+    } SeBackupPrivilege
+}
+
+proc twapi::reg_key_import {hkey filepath args} {
+    parseargs args {
+        {volatile.bool 0 0x1}
+        {force.bool 0 0x8}
+    } -setvars
+    twapi::eval_with_privileges {
+        RegRestoreKey $hkey $filepath [expr {$force | $volatile}]
+    } {SeBackupPrivilege SeRestorePrivilege}
+}
+
+proc twapi::reg_key_load {hkey hivename filepath} {
+    twapi::eval_with_privileges {
+        RegLoadKey $hkey $subkey $filepath
+    } {SeBackupPrivilege SeRestorePrivilege}
+}
+
+proc twapi::reg_key_unload {hkey hivename} {
+    twapi::eval_with_privileges {
+        RegUnLoadKey $hkey $subkey
+    } {SeBackupPrivilege SeRestorePrivilege}
+}
+
+proc twapi::reg_key_monitor {hkey hevent args} {
+    parseargs args {
+        {keys.bool 0 0x1}
+        {attr.bool 0 0x2}
+        {values.bool 0 0x4}
+        {secd.bool 0 0x8}
+        {subtree.bool 0}
+    } -setvars
+
+    set filter [expr {$keys | $attr | $values | $secd}]
+    if {$filter == 0} {
+        set filter 0xf
+    }
+
+    RegNotifyChangeKeyValue $hkey $subtree $filter $hevent 1
+}
+
+proc twapi::reg_value_names {hkey {subkey {}}} {
+    if {$subkey eq ""} {
+        # 0 - value names only
+        return [RegEnumValue $hkey 0]
+    }
+    set hkey [reg_key_open $hkey $subkey]
+    try {
+        # 0 - value names only
+        return [RegEnumValue $hkey 0]
+    } finally {
+        reg_key_close $hkey
+    }
+}
+
+proc twapi::reg_values {hkey {subkey {}}} {
+    if {$subkey eq ""} {
+        #  3 -> 0x1 - return data values, 0x2 - cooked data
+        return [RegEnumValue $hkey 3]
+    }
+    set hkey [reg_key_open $hkey $subkey]
+    try {
+        #  3 -> 0x1 - return data values, 0x2 - cooked data
+        return [RegEnumValue $hkey 3]
+    } finally {
+        reg_key_close $hkey
+    }
+}
+
+proc twapi::reg_values_raw {hkey {subkey {}}} {
+    if {$subkey eq ""} {
+        #  0x1 - return data values
+        return [RegEnumValue $hkey 1]
+    }
+    set hkey [reg_key_open $hkey $subkey]
+    try {
+        return [RegEnumValue $hkey 1]
+    } finally {
+        reg_key_close $hkey
+    }
+}
+
+proc twapi::reg_value_raw {hkey args} {
+    if {[llength $args] == 1} {
+        return [RegQueryValueEx $hkey [lindex $args 0] false]
+    } elseif {[llength $args] == 2} {
+        return [RegGetValue $hkey {*}$args 0x1000ffff false]
+    } else {
+        error "wrong # args: should be \"reg_value_get HKEY ?SUBKEY? VALUENAME\""
+    }
+}
+
+proc twapi::reg_value {hkey args} {
+    if {[llength $args] == 1} {
+        return [RegQueryValueEx $hkey [lindex $args 0] true]
+    } elseif {[llength $args] == 2} {
+        return [RegGetValue $hkey {*}$args 0x1000ffff true]
+    } else {
+        error "wrong # args: should be \"reg_value_get HKEY ?SUBKEY? VALUENAME\""
+    }
+}
+
+if {[twapi::min_os_version 6]} {
+    proc twapi::reg_value_set {hkey args} {
+        if {[llength $args] == 3} {
+            return [RegSetValueEx $hkey {*}$args]
+        } elseif {[llength $args] == 4} {
+            return [RegSetKeyValue $hkey {*}$args]
+        } else {
+            error "wrong # args: should be \"reg_value_set HKEY ?SUBKEY? VALUENAME TYPE VALUE\""
+        }
+    }
+} else {
+    proc twapi::reg_value_set {hkey args} {
+        if {[llength $args] == 3} {
+            lassign $args value_name value_type value
+        } elseif {[llength $args] == 4} {
+            lassign $args subkey value_name value_type value
+            set hkey [reg_key_open $hkey $subkey -access key_set_value]
+        } else {
+            error "wrong # args: should be \"reg_value_set HKEY ?SUBKEY? VALUENAME TYPE VALUE\""
+        }
+        try {
+            RegSetValueEx $hkey $value_name $value_type $value
+        } finally {
+            if {[info exists subkey]} {
+                # We opened hkey
+                reg_close_key $hkey
+            }
+        }
+    }
+}
+
+proc twapi::reg_key_override_undo {hkey} {
+    RegOverridePredefKey $hkey 0
+}
+
+proc twapi::_reg_walker {hkey path callback cbdata} {
+    # Callback for the key
+    set code [catch {
+        {*}$callback $cbdata $hkey $path
+    } cbdata ropts]
+    if {$code != 0} {
+        if {$code == 4} {
+            # Continue - skip children, continue with siblings
+            return $cbdata
+        } elseif {$code == 3} {
+            # Skip siblings as well
+            return -code break $cbdata
+        } elseif {$code == 2} {
+            # Stop complete iteration
+            return -code return $cbdata
+        } else {
+            return -options $ropts $cbdata
+        }
+    }
+
+    # Iterate over child keys
+    foreach child_key [reg_keys $hkey] {
+        set child_hkey [reg_key_open $hkey $child_key]
+        try {
+            # Recurse to call into children
+            set code [catch {
+                _reg_walker $child_hkey [linsert $path end $child_key] $callback $cbdata
+            } cbdata ropts]
+            if {$code != 0 && $code != 4} {
+                if {$code == 3} {
+                    # break - skip remaining child keys
+                    return $cbdata
+                } elseif {$code == 2} {
+                    # return - stop all iteration all up the tree
+                    return -code return $cbdata
+                } else {
+                    return -options $ropts $cbdata
+                }
+            }
+        } finally {
+            reg_key_close $child_hkey
+        }
+    }
+
+    return $cbdata
+}
+
+proc twapi::reg_walk {hkey args} {
+    parseargs args {
+        {subkey.arg {}}
+        callback.arg
+        {cbdata.arg ""}
+    } -maxleftover 0 -setvars
+
+
+    if {$subkey ne ""} {
+        set hkey [reg_key_open $hkey $subkey]
+        set path [list $subkey]
+    } else {
+        set path [list ]
+    }
+
+    if {![info exists callback]} {
+        set callback [lambda {cbdata hkey path} {puts [join $path \\]}]
+    }
+    try {
+        set code [catch {_reg_walker $hkey $path $callback $cbdata } result ropts]
+        # Codes 2 (return), 3 (break) and 4 (continue) are just early terminations
+        if {$code == 1} {
+            return -options $ropts $result
+        }
+    } finally {
+        if {$subkey ne ""} {
+            reg_key_close $hkey
+        }
+    }
+    return $result
+}
+
+proc twapi::_reg_iterator_callback {cbdata hkey path args} {
+    set cmd [yield [list $hkey $path {*}$args]]
+    # Loop until valid argument
+    while {1} {
+        switch -exact -- $cmd {
+            "" -
+            next { return $cbdata }
+            stop { return -code return $cbdata }
+            parentsibling { return -code break $cbdata }
+            sibling { return -code continue $cbdata }
+            default {
+                set ret [yieldto return -level 0 -code error "Invalid argument \"$cmd\"."]
+            }
+        }
+    }
+}
+
+proc twapi::_reg_iterator_coro {hkey subkey} {
+    set cmd [yield [info coroutine]]
+    switch -exact -- $cmd {
+        "" -
+        next {
+            # Drop into reg_walk
+        }
+        stop -
+        parentsibling -
+        sibling {
+            return {}
+        }
+        default {
+            error "Invalid argument \"$cmd\"."
+        }
+    }
+    if {$subkey ne ""} {
+        set hkey [reg_key_open $hkey $subkey]
+    }
+    try {
+        reg_walk $hkey -callback [namespace current]::_reg_iterator_callback
+    } finally {
+        if {$subkey ne ""} {
+            reg_key_close $hkey
+        }
+    }
+    return
+}
+
+proc twapi::reg_iterator {hkey {subkey {}}} {
+    variable reg_walk_counter
+
+    return [coroutine "regwalk#[incr reg_walk_counter]" _reg_iterator_coro $hkey $subkey]
+}
+
+proc twapi::reg_tree {hkey {subkey {}}} {
+
+    set iter [reg_iterator $hkey $subkey]
+
+    set paths {}
+    while {[llength [set item [$iter next]]]} {
+        lappend paths [join [lindex $item 1] \\]
+    }
+    return $paths
+}
+
+proc twapi::reg_tree_values {hkey {subkey {}}} {
+
+    set iter [reg_iterator $hkey $subkey]
+
+    set tree {}
+    # Note here we cannot ignore the first empty node corresponding
+    # to the root because we have to return any values it contains.
+    while {[llength [set item [$iter next]]]} {
+        dict set tree [join [lindex $item 1] \\] [reg_values [lindex $item 0]]
+    }
+    return $tree
+}
+
+proc twapi::reg_tree_values_raw {hkey {subkey {}}} {
+    set iter [reg_iterator $hkey $subkey]
+
+    set tree {}
+    while {[llength [set item [$iter next]]]} {
+        dict set tree [join [lindex $item 1] \\] [reg_values_raw [lindex $item 0]]
+    }
+    return $tree
+}
+

src/punk86.vfs/lib/twapi4.7.2/resource.tcl

@@ -0,0 +1,458 @@
+# Commands related to resource manipulation
+#
+# Copyright (c) 2003-2012 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+package require twapi_nls
+
+# Retrieve version info for a file
+proc twapi::get_file_version_resource {path args} {
+    array set opts [parseargs args {
+        all
+        datetime
+        signature
+        structversion
+        fileversion
+        productversion
+        flags
+        fileos
+        filetype
+        foundlangid
+        foundcodepage
+        langid.arg
+        codepage.arg
+    }]
+
+
+    set ver [Twapi_GetFileVersionInfo $path]
+
+    trap {
+        array set verinfo [Twapi_VerQueryValue_FIXEDFILEINFO $ver]
+
+        set result [list ]
+        if {$opts(all) || $opts(signature)} {
+            lappend result -signature [format 0x%x $verinfo(dwSignature)]
+        }
+
+        if {$opts(all) || $opts(structversion)} {
+            lappend result -structversion "[expr {0xffff & ($verinfo(dwStrucVersion) >> 16)}].[expr {0xffff & $verinfo(dwStrucVersion)}]"
+        }
+
+        if {$opts(all) || $opts(fileversion)} {
+            lappend result -fileversion "[expr {0xffff & ($verinfo(dwFileVersionMS) >> 16)}].[expr {0xffff & $verinfo(dwFileVersionMS)}].[expr {0xffff & ($verinfo(dwFileVersionLS) >> 16)}].[expr {0xffff & $verinfo(dwFileVersionLS)}]"
+        }
+
+        if {$opts(all) || $opts(productversion)} {
+            lappend result -productversion "[expr {0xffff & ($verinfo(dwProductVersionMS) >> 16)}].[expr {0xffff & $verinfo(dwProductVersionMS)}].[expr {0xffff & ($verinfo(dwProductVersionLS) >> 16)}].[expr {0xffff & $verinfo(dwProductVersionLS)}]"
+        }
+
+        if {$opts(all) || $opts(flags)} {
+            set flags [expr {$verinfo(dwFileFlags) & $verinfo(dwFileFlagsMask)}]
+            lappend result -flags \
+                [_make_symbolic_bitmask \
+                     [expr {$verinfo(dwFileFlags) & $verinfo(dwFileFlagsMask)}] \
+                     {
+                         debug 1
+                         prerelease 2
+                         patched 4
+                         privatebuild 8
+                         infoinferred 16
+                         specialbuild 32
+                     } \
+                     ]
+        }
+
+        if {$opts(all) || $opts(fileos)} {
+            switch -exact -- [format %08x $verinfo(dwFileOS)] {
+                00010000 {set os dos}
+                00020000 {set os os216}
+                00030000 {set os os232}
+                00040000 {set os nt}
+                00050000 {set os wince}
+                00000001 {set os windows16}
+                00000002 {set os pm16}
+                00000003 {set os pm32}
+                00000004 {set os windows32}
+                00010001 {set os dos_windows16}
+                00010004 {set os dos_windows32}
+                00020002 {set os os216_pm16}
+                00030003 {set os os232_pm32}
+                00040004 {set os nt_windows32}
+                default {set os $verinfo(dwFileOS)}
+            }
+            lappend result -fileos $os
+        }
+
+        if {$opts(all) || $opts(filetype)} {
+            switch -exact -- [expr {0+$verinfo(dwFileType)}] {
+                1 {set type application}
+                2 {set type dll}
+                3 {
+                    set type "driver."
+                    switch -exact -- [expr {0+$verinfo(dwFileSubtype)}] {
+                        1 {append type printer}
+                        2 {append type keyboard}
+                        3 {append type language}
+                        4 {append type display}
+                        5 {append type mouse}
+                        6 {append type network}
+                        7 {append type system}
+                        8 {append type installable}
+                        9  {append type sound}
+                        10 {append type comm}
+                        11 {append type inputmethod}
+                        12 {append type versionedprinter}
+                        default {append type $verinfo(dwFileSubtype)}
+                    }
+                }
+                4 {
+                    set type "font."
+                    switch -exact -- [expr {0+$verinfo(dwFileSubtype)}] {
+                        1 {append type raster}
+                        2 {append type vector}
+                        3 {append type truetype}
+                        default {append type $verinfo(dwFileSubtype)}
+                    }
+                }
+                5 { set type "vxd.$verinfo(dwFileSubtype)" }
+                7 {set type staticlib}
+                default {
+                    set type "$verinfo(dwFileType).$verinfo(dwFileSubtype)"
+                }
+            }
+            lappend result -filetype $type
+        }
+
+        if {$opts(all) || $opts(datetime)} {
+            lappend result -datetime [expr {($verinfo(dwFileDateMS) << 32) + $verinfo(dwFileDateLS)}]
+        }
+
+        # Any remaining arguments are treated as string names
+
+        if {[llength $args] || $opts(foundlangid) || $opts(foundcodepage) || $opts(all)} {
+            # Find list of langid's and codepages and do closest match
+            set langid [expr {[info exists opts(langid)] ? $opts(langid) : [get_user_ui_langid]}]
+            set primary_langid [extract_primary_langid $langid]
+            set sub_langid     [extract_sublanguage_langid $langid]
+            set cp [expr {[info exists opts(codepage)] ? $opts(codepage) : 0}]
+
+            # Find a match in the following order:
+            # 0 Exact match for both langid and codepage
+            # 1 Exact match for langid
+            # 2 Primary langid matches (sublang does not) and exact codepage
+            # 3 Primary langid matches (sublang does not)
+            # 4 Language neutral
+            # 5 English
+            # 6 First langcp in list or "00000000"
+            set match(7) "00000000";    # In case list is empty
+            foreach langcp [Twapi_VerQueryValue_TRANSLATIONS $ver] {
+                set verlangid 0x[string range $langcp 0 3]
+                set vercp 0x[string range $langcp 4 7]
+                if {$verlangid == $langid && $vercp == $cp} {
+                    set match(0) $langcp
+                    break;              # No need to look further
+                }
+                if {[info exists match(1)]} continue
+                if {$verlangid == $langid} {
+                    set match(1) $langcp
+                    continue;           # Continue to look for match(0)
+                }
+                if {[info exists match(2)]} continue
+                set verprimary [extract_primary_langid $verlangid]
+                if {$verprimary == $primary_langid && $vercp == $cp} {
+                    set match(2) $langcp
+                    continue;       # Continue to look for match(1) or better
+                }
+                if {[info exists match(3)]} continue
+                if {$verprimary == $primary_langid} {
+                    set match(3) $langcp
+                    continue;       # Continue to look for match(2) or better
+                }
+                if {[info exists match(4)]} continue
+                if {$verprimary == 0} {
+                    set match(4) $langcp; # LANG_NEUTRAL
+                    continue;       # Continue to look for match(3) or better
+                }
+                if {[info exists match(5)]} continue
+                if {$verprimary == 9} {
+                    set match(5) $langcp; # English
+                    continue;       # Continue to look for match(4) or better
+                }
+                if {![info exists match(6)]} {
+                    set match(6) $langcp
+                }
+            }
+
+            # Figure out what is the best match we have
+            for {set i 0} {$i <= 7} {incr i} {
+                if {[info exists match($i)]} {
+                    break
+                }
+            }
+
+            if {$opts(foundlangid) || $opts(all)} {
+                set langid 0x[string range $match($i) 0 3] 
+                lappend result -foundlangid [list $langid [VerLanguageName $langid]]
+            }
+
+            if {$opts(foundcodepage) || $opts(all)} {
+                lappend result -foundcodepage 0x[string range $match($i) 4 7]
+            }
+
+            foreach sname $args {
+                lappend result $sname [Twapi_VerQueryValue_STRING $ver $match($i) $sname]
+            }
+
+        }
+
+    } finally {
+        Twapi_FreeFileVersionInfo $ver
+    }
+
+    return $result
+}
+
+proc twapi::begin_resource_update {path args} {
+    array set opts [parseargs args {
+        deleteall
+    } -maxleftover 0]
+
+    return [BeginUpdateResource $path $opts(deleteall)]
+}
+
+# Note this is not an alias because we want to control arguments
+# to UpdateResource (which can take more args that specified here)
+proc twapi::delete_resource {hmod restype resname langid} {
+    UpdateResource $hmod $restype $resname $langid
+}
+
+
+# Note this is not an alias because we want to make sure $bindata is specified
+# as an argument else it will have the effect of deleting a resource
+proc twapi::update_resource {hmod restype resname langid bindata} {
+    UpdateResource $hmod $restype $resname $langid $bindata
+}
+
+proc twapi::end_resource_update {hmod args} {
+    array set opts [parseargs args {
+        discard
+    } -maxleftover 0]
+
+    return [EndUpdateResource $hmod $opts(discard)]
+}
+
+proc twapi::read_resource {hmod restype resname langid} {
+    return [Twapi_LoadResource $hmod [FindResourceEx $hmod $restype $resname $langid]]
+}
+
+proc twapi::read_resource_string {hmod resname langid} {
+    # As an aside, note that we do not use a LoadString call
+    # because it does not allow for specification of a langid
+    
+    # For a reference to how strings are stored, see
+    # http://blogs.msdn.com/b/oldnewthing/archive/2004/01/30/65013.aspx
+    # or http://support.microsoft.com/kb/196774
+
+    if {![string is integer -strict $resname]} {
+        error "String resources must have an integer id"
+    }
+
+    lassign [resource_stringid_to_stringblockid $resname]  block_id index_within_block
+
+    return [lindex \
+                [resource_stringblock_to_strings \
+                     [read_resource $hmod 6 $block_id $langid] ] \
+                $index_within_block]
+}
+
+# Give a list of strings, formats it as a string block. Number of strings
+# must not be greater than 16. If less than 16 strings, remaining are
+# treated as empty.
+proc twapi::strings_to_resource_stringblock {strings} {
+    if {[llength $strings] > 16} {
+        error "Cannot have more than 16 strings in a resource string block."
+    }
+
+    for {set i 0} {$i < 16} {incr i} {
+        set s [lindex $strings $i]
+        set n [string length $s]
+        append bin [binary format sa* $n [encoding convertto unicode $s]]
+    }
+
+    return $bin
+}
+
+proc twapi::resource_stringid_to_stringblockid {id} {
+    # Strings are stored in blocks of 16, with block id's beginning at 1, not 0
+    return [list [expr {($id / 16) + 1}] [expr {$id & 15}]]
+}
+
+proc twapi::extract_resources {hmod {withdata 0}} {
+    set result [dict create]
+    foreach type [enumerate_resource_types $hmod] {
+        set typedict [dict create]
+        foreach name [enumerate_resource_names $hmod $type] {
+            set namedict [dict create]
+            foreach lang [enumerate_resource_languages $hmod $type $name] {
+                if {$withdata} {
+                    dict set namedict $lang [read_resource $hmod $type $name $lang]
+                } else {
+                    dict set namedict $lang {}
+                }
+            }
+            dict set typedict $name $namedict
+        }
+        dict set result $type $typedict
+    }
+    return $result
+}
+
+# TBD - test
+proc twapi::write_bmp_file {filename bmp} {
+    # Assumes $bmp is clipboard content in format 8 (CF_DIB)
+
+    # First parse the bitmap data to collect header information
+    binary scan $bmp "iiissiiiiii" size width height planes bitcount compression sizeimage xpelspermeter ypelspermeter clrused clrimportant
+
+    # We only handle BITMAPINFOHEADER right now (size must be 40)
+    if {$size != 40} {
+        error "Unsupported bitmap format. Header size=$size"
+    }
+
+    # We need to figure out the offset to the actual bitmap data
+    # from the start of the file header. For this we need to know the
+    # size of the color table which directly follows the BITMAPINFOHEADER
+    if {$bitcount == 0} {
+        error "Unsupported format: implicit JPEG or PNG"
+    } elseif {$bitcount == 1} {
+        set color_table_size 2
+    } elseif {$bitcount == 4} {
+        # TBD - Not sure if this is the size or the max size
+        set color_table_size 16
+    } elseif {$bitcount == 8} {
+        # TBD - Not sure if this is the size or the max size
+        set color_table_size 256
+    } elseif {$bitcount == 16 || $bitcount == 32} {
+        if {$compression == 0} {
+            # BI_RGB
+            set color_table_size $clrused
+        } elseif {$compression == 3} {
+            # BI_BITFIELDS
+            set color_table_size 3
+        } else {
+            error "Unsupported compression type '$compression' for bitcount value $bitcount"
+        }
+    } elseif {$bitcount == 24} {
+        set color_table_size $clrused
+    } else {
+        error "Unsupported value '$bitcount' in bitmap bitcount field"
+    }
+
+    set filehdr_size 14;                # sizeof(BITMAPFILEHEADER)
+    set bitmap_file_offset [expr {$filehdr_size+$size+($color_table_size*4)}]
+    set filehdr [binary format "a2 i x2 x2 i" "BM" [expr {$filehdr_size + [string length $bmp]}] $bitmap_file_offset]
+
+    set fd [open $filename w]
+    fconfigure $fd -translation binary
+
+    puts -nonewline $fd $filehdr
+    puts -nonewline $fd $bmp
+
+    close $fd
+}
+
+proc twapi::_load_image {flags type hmod path args} {
+    # The flags arg is generally 0x10 (load from file), or 0 (module)
+    # or'ed with 0x8000 (shared). The latter can be overridden by
+    # the -shared option but should not be except when loading from module.
+    array set opts [parseargs args {
+        {createdibsection.bool 0 0x2000}
+        {defaultsize.bool  0  0x40}
+        height.int
+        {loadtransparent.bool 0 0x20}
+        {monochrome.bool  0  0x1}
+        {shared.bool  0  0x8000}
+        {vgacolor.bool  0  0x80}
+        width.int
+    } -maxleftover 0 -nulldefault]
+
+    set flags [expr {$flags | $opts(defaultsize) | $opts(loadtransparent) | $opts(monochrome) | $opts(shared) | $opts(vgacolor)}]
+
+    set h [LoadImage $hmod $path $type $opts(width) $opts(height) $flags]
+    # Cast as _SHARED if required to offer some protection against
+    # being freed using DestroyIcon etc.
+    set type [lindex {HGDIOBJ HICON HCURSOR} $type]
+    if {$flags & 0x8000} {
+        append type _SHARED
+    }
+    return [cast_handle $h $type]
+}
+
+
+proc twapi::_load_image_from_system {type id args} {
+    variable _oem_image_syms
+
+    if {![string is integer -strict $id]} {
+        if {![info exists _oem_image_syms]} {
+            # Bitmap symbols (type 0)
+            dict set _oem_image_syms 0 {
+                CLOSE           32754            UPARROW         32753
+                DNARROW         32752            RGARROW         32751
+                LFARROW         32750            REDUCE          32749
+                ZOOM            32748            RESTORE         32747
+                REDUCED         32746            ZOOMD           32745
+                RESTORED        32744            UPARROWD        32743
+                DNARROWD        32742            RGARROWD        32741
+                LFARROWD        32740            MNARROW         32739
+                COMBO           32738            UPARROWI        32737
+                DNARROWI        32736            RGARROWI        32735
+                LFARROWI        32734            SIZE            32766
+                BTSIZE          32761            CHECK           32760
+                CHECKBOXES      32759            BTNCORNERS      32758
+            }            
+            # Icon symbols (type 1)
+            dict set _oem_image_syms 1 {
+                SAMPLE          32512            HAND            32513
+                QUES            32514            BANG            32515
+                NOTE            32516            WINLOGO         32517
+                WARNING         32515            ERROR           32513
+                INFORMATION     32516            SHIELD          32518
+            }
+            # Cursor symbols (type 2)
+            dict set _oem_image_syms 2 {
+                NORMAL          32512            IBEAM           32513
+                WAIT            32514            CROSS           32515
+                UP              32516            SIZENWSE        32642
+                SIZENESW        32643            SIZEWE          32644
+                SIZENS          32645            SIZEALL         32646
+                NO              32648            HAND            32649
+                APPSTARTING     32650
+            }
+
+        }
+    }
+        
+    set id [dict get $_oem_image_syms $type [string toupper $id]]
+    # Built-in system images must always be loaded shared (0x8000)
+    return [_load_image 0x8000 $type NULL $id {*}$args]
+}
+
+
+# 0x10 -> LR_LOADFROMFILE. Also 0x8000 not set (meaning unshared)
+interp alias {} twapi::load_bitmap_from_file {} twapi::_load_image 0x10 0 NULL
+interp alias {} twapi::load_icon_from_file {} twapi::_load_image 0x10 1 NULL
+interp alias {} twapi::load_cursor_from_file {} twapi::_load_image 0x10 2 NULL
+
+interp alias {} twapi::load_bitmap_from_module {} twapi::_load_image 0 0
+interp alias {} twapi::load_icon_from_module {} twapi::_load_image   0 1
+interp alias {} twapi::load_cursor_from_module {} twapi::_load_image 0 2
+
+interp alias {} twapi::load_bitmap_from_system {} twapi::_load_image_from_system 0
+interp alias {} twapi::load_icon_from_system {} twapi::_load_image_from_system   1
+interp alias {} twapi::load_cursor_from_system {} twapi::_load_image_from_system 2
+
+interp alias {} twapi::free_icon {} twapi::DestroyIcon
+interp alias {} twapi::free_bitmap {} twapi::DeleteObject
+interp alias {} twapi::free_cursor {} twapi::DestroyCursor

src/punk86.vfs/lib/twapi4.7.2/share.tcl

@@ -0,0 +1,966 @@
+#
+# Copyright (c) 2003-2014, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {
+    # Win SDK based structure definitions
+
+    record SHARE_INFO_0 {-name}
+    record SHARE_INFO_1 {-name -type -comment}
+    record SHARE_INFO_2 {-name -type -comment -permissions -max_conn -current_conn -path -passwd}
+    record SHARE_INFO_502 {-name -type -comment -permissions -max_conn -current_conn -path -passwd -reserved -secd}
+
+    record USE_INFO_0 {-localdevice -remoteshare}
+    record USE_INFO_1 {-localdevice -remoteshare -password -status -type -opencount -usecount}
+    record USE_INFO_2 {-localdevice -remoteshare -password -status -type -opencount -usecount -user -domain}
+
+    record SESSION_INFO_0 {-clientname}
+    record SESSION_INFO_1 {-clientname -user -opencount -activeseconds -idleseconds -attrs}
+    record SESSION_INFO_2 {-clientname -user -opencount -activeseconds -idleseconds -attrs -clienttype}
+    record SESSION_INFO_502 {-clientname -user -opencount -activeseconds -idleseconds -attrs -clienttype -transport}
+    record SESSION_INFO_10 {-clientname -user -activeseconds -idleseconds}
+
+    record FILE_INFO_2 {-id}
+    record FILE_INFO_3 {-id -permissions -lockcount -path -user}
+
+    record CONNECTION_INFO_0 {-id}
+    record CONNECTION_INFO_1 {-id -type -opencount -usercount -activeseconds -user -netname}
+
+    struct NETRESOURCE {
+        DWORD  dwScope;
+        DWORD  dwType;
+        DWORD  dwDisplayType;
+        DWORD  dwUsage;
+        LPCWSTR lpLocalName;
+        LPCWSTR lpRemoteName;
+        LPCWSTR lpComment;
+        LPCWSTR lpProvider;
+    };
+
+    struct NETINFOSTRUCT {
+        DWORD     cbStructure;
+        DWORD     dwProviderVersion;
+        DWORD     dwStatus;
+        DWORD     dwCharacteristics;
+        HANDLE    dwHandle;
+        WORD      wNetType;
+        DWORD     dwPrinters;
+        DWORD     dwDrives;
+    }
+}
+
+# TBD - is there a Tcl wrapper around NetShareCheck?
+
+# Create a network share
+proc twapi::new_share {sharename path args} {
+    array set opts [parseargs args {
+        {system.arg ""}
+        {type.arg "file"}
+        {comment.arg ""}
+        {max_conn.int -1}
+        secd.arg
+    } -maxleftover 0]
+
+    # If no security descriptor specified, default to "Everyone,
+    # read permission". Levaing it empty will give everyone all permissions
+    # which is probably not a good idea!
+    if {![info exists opts(secd)]} {
+        set opts(secd) [new_security_descriptor -dacl [new_acl [list [new_ace allow S-1-1-0 1179817]]]]
+    }
+    
+    NetShareAdd $opts(system) \
+        $sharename \
+        [_share_type_symbols_to_code $opts(type)] \
+        $opts(comment) \
+        $opts(max_conn) \
+        [file nativename $path] \
+        $opts(secd)
+}
+
+# Delete a network share
+proc twapi::delete_share {sharename args} {
+    array set opts [parseargs args {system.arg} -nulldefault]
+    NetShareDel $opts(system) $sharename 0
+}
+
+# Enumerate network shares
+proc twapi::get_shares {args} {
+
+    array set opts [parseargs args {
+        {system.arg ""}
+        {type.arg ""}
+        excludespecial
+        level.int
+    } -maxleftover 0]
+
+    if {$opts(type) != ""} {
+        set type_filter [_share_type_symbols_to_code $opts(type) 1]
+    }
+
+    if {[info exists opts(level)] && $opts(level) > 0} {
+        set level $opts(level)
+    } else {
+        # Either -level not specified or specified as 0
+        # We need at least level 1 to filter on type
+        set level 1
+    }
+
+    set record_proc SHARE_INFO_$level
+    set raw_data [_net_enum_helper NetShareEnum -system $opts(system) -level $level -fields [$record_proc]]
+    set recs [list ]
+    foreach rec [recordarray getlist $raw_data] {
+        # 0xC0000000 -> 0x80000000 (STYPE_SPECIAL), 0x40000000 (STYPE_TEMPORARY)
+        set special [expr {[$record_proc -type $rec] & 0xC0000000}]
+        if {$special && $opts(excludespecial)} {
+            continue
+        }
+        # We need the special cast to int because else operands get promoted
+        # to 64 bits as the hex is treated as an unsigned value
+        set share_type [$record_proc -type $rec]
+        if {[info exists type_filter] && [expr {int($share_type & ~ $special)}] != $type_filter} {
+            continue
+        }
+        set rec [$record_proc set $rec -type [_share_type_code_to_symbols $share_type]]
+        if {[info exists opts(level)]} {
+            lappend recs $rec
+        } else {
+            lappend recs [$record_proc -name $rec]
+        }
+    }
+
+    if {[info exists opts(level)]} {
+        set ra [list [$record_proc] $recs]
+        if {$opts(level) == 0} {
+            # We actually need only a level 0 subset
+            return [recordarray get $ra -slice [SHARE_INFO_0]]
+        }
+        return $ra
+    } else {
+        return $recs
+    }
+}
+
+
+# Get details about a share
+proc twapi::get_share_info {sharename args} {
+    array set opts [parseargs args {
+        system.arg
+        all
+        name
+        type
+        path
+        comment
+        max_conn
+        current_conn
+        secd
+    } -nulldefault -hyphenated]
+
+    set level 0
+
+    if {$opts(-all) || $opts(-name) || $opts(-type) || $opts(-comment)} {
+        set level 1
+        set record_proc SHARE_INFO_1
+    }
+
+    if {$opts(-all) || $opts(-max_conn) || $opts(-current_conn) || $opts(-path)} {
+        set level 2
+        set record_proc SHARE_INFO_2
+    }
+
+    if {$opts(-all) || $opts(-secd)} {
+        set level 502
+        set record_proc SHARE_INFO_502
+    }
+
+    if {! $level} {
+        return
+    }
+
+    set rec [NetShareGetInfo $opts(-system) $sharename $level]
+    set result [list ]
+    foreach opt {-name -comment -max_conn -current_conn -path -secd} {
+        if {$opts(-all) || $opts($opt)} {
+            lappend result $opt [$record_proc $opt $rec]
+        }
+    }
+    if {$opts(-all) || $opts(-type)} {
+        lappend result -type [_share_type_code_to_symbols [$record_proc -type $rec]]
+    }
+
+    return $result
+}
+
+
+# Set a share configuration
+proc twapi::set_share_info {sharename args} {
+    array set opts [parseargs args {
+        {system.arg ""}
+        comment.arg
+        max_conn.int
+        secd.arg
+    }]
+
+    # First get the current config so we can change specified fields
+    # and write back
+    array set shareinfo [get_share_info $sharename -system $opts(system) \
+                             -comment -max_conn -secd]
+    foreach field {comment max_conn secd} {
+        if {[info exists opts($field)]} {
+            set shareinfo(-$field) $opts($field)
+        }
+    }
+
+    NetShareSetInfo $opts(system) $sharename $shareinfo(-comment) \
+        $shareinfo(-max_conn) $shareinfo(-secd)
+}
+
+
+# Get list of remote shares
+proc twapi::get_client_shares {args} {
+    array set opts [parseargs args {
+        {system.arg ""}
+        level.int
+    } -maxleftover 0]
+
+    if {[info exists opts(level)]} {
+        set rec_proc USE_INFO_$opts(level)
+        set ra [_net_enum_helper NetUseEnum -system $opts(system) -level $opts(level) -fields [$rec_proc]]
+        set fields [$rec_proc]
+        set have_status [expr {"-status" in $fields}]
+        set have_type [expr {"-type" in $fields}]
+        if {! ($have_status || $have_type)} {
+            return $ra
+        }
+        set recs {}
+        foreach rec [recordarray getlist $ra] {
+            if {$have_status} {
+                set rec [$rec_proc set $rec -status [_map_useinfo_status [$rec_proc -status $rec]]]
+            }
+            if {$have_type} {
+                set rec [$rec_proc set $rec -type [_map_useinfo_type [$rec_proc -type $rec]]]
+            }
+            lappend recs $rec
+        }
+        return [list $fields $recs]
+    }
+
+    # -level not specified. Just return a list of the remote share names
+    return [recordarray column [_net_enum_helper NetUseEnum -system $opts(system) -level 0 -fields [USE_INFO_0]] -remoteshare]
+}
+
+
+# Connect to a share
+proc twapi::connect_share {remoteshare args} {
+    array set opts [parseargs args {
+        {type.arg  "disk"} 
+        localdevice.arg
+        provider.arg
+        password.arg
+        nopassword
+        defaultpassword
+        user.arg
+        {window.arg 0}
+        {interactive {} 0x8}
+        {prompt      {} 0x10}
+        {updateprofile {} 0x1}
+        {commandline {} 0x800}
+    } -nulldefault]
+
+    set flags 0
+
+    switch -exact -- $opts(type) {
+        "any"       {set type 0}
+        "disk"      -
+        "file"      {set type 1}
+        "printer"   {set type 2}
+        default {
+            error "Invalid network share type '$opts(type)'"
+        }
+    }
+
+    # localdevice - "" means no local device, * means pick any, otherwise
+    # it's a local device to be mapped
+    if {$opts(localdevice) == "*"} {
+        set opts(localdevice) ""
+        setbits flags 0x80;             # CONNECT_REDIRECT
+    }
+
+    if {$opts(defaultpassword) && $opts(nopassword)} {
+        error "Options -defaultpassword and -nopassword may not be used together"
+    }
+    if {$opts(nopassword)} {
+        set opts(password) ""
+        set ignore_password 1
+    } else {
+        set ignore_password 0
+        if {$opts(defaultpassword)} {
+            set opts(password) ""
+        }
+    }
+
+    set flags [expr {$flags | $opts(interactive) | $opts(prompt) |
+                     $opts(updateprofile) | $opts(commandline)}]
+
+    return [Twapi_WNetUseConnection $opts(window) $type $opts(localdevice) \
+                $remoteshare $opts(provider) $opts(user) $ignore_password \
+                $opts(password) $flags]
+}
+
+# Disconnects an existing share
+proc twapi::disconnect_share {sharename args} {
+    array set opts [parseargs args {updateprofile force}]
+
+    set flags [expr {$opts(updateprofile) ? 0x1 : 0}]
+    WNetCancelConnection2 $sharename $flags $opts(force)
+}
+
+
+# Get information about a connected share
+proc twapi::get_client_share_info {sharename args} {
+    if {$sharename eq ""} {
+        error "A share name cannot be the empty string"
+    }
+
+    # We have to use a combination of NetUseGetInfo and 
+    # WNetGetResourceInformation as neither gives us the full information
+    # THe former takes the local device name if there is one and will
+    # only accept a UNC if there is an entry for the UNC with
+    # no local device mapped. The latter
+    # always wants the UNC. So we need to figure out exactly if there
+    # is a local device mapped to the sharename or not
+    # TBD _ see if this is really the case. Also, NetUse only works with
+    # LANMAN, not WebDAV. So see if there is a way to only use WNet*
+    # variants
+    
+    # There may be multiple entries for the same UNC
+    # If there is an entry for the UNC with no device mapped, select
+    # that else select any of the local devices mapped to it
+    # TBD - any better way of finding out a mapping than calling
+    # get_client_shares?
+    # TBD - use wnet_connected_resources
+    foreach {elem_device elem_unc} [recordarray getlist [get_client_shares -level 0] -format flat] {
+        if {[string equal -nocase $sharename $elem_unc]} {
+            if {$elem_device eq ""} {
+                # Found an entry without a local device. Use it
+                set unc $elem_unc
+                unset -nocomplain local; # In case we found a match earlier
+                break
+            } else {
+                # Found a matching device
+                set local $elem_device
+                set unc $elem_unc
+                # Keep looping in case we find an entry with no local device
+                # (which we will prefer)
+            }
+        } else {
+            # See if the sharename is actually a local device name
+            if {[string equal -nocase [string trimright $elem_device :] [string trimright $sharename :]]} {
+                # Device name matches. Use it
+                set local $elem_device
+                set unc $elem_unc
+                break
+            }
+        }
+    }
+
+    if {![info exists unc]} {
+        win32_error 2250 "Share '$sharename' not found."
+    }
+
+    # At this point $unc is the UNC form of the share and
+    # $local is either undefined or the local mapped device if there is one
+
+    array set opts [parseargs args {
+        user
+        localdevice
+        remoteshare
+        status
+        type
+        opencount
+        usecount
+        domain
+        provider
+        comment
+        all
+    } -maxleftover 0 -hyphenated]
+
+
+    # Call Twapi_NetGetInfo always to get status. If we are not connected,
+    # we will not call WNetGetResourceInformation as that will time out
+    if {[info exists local]} {
+        set share [NetUseGetInfo "" $local 2]
+    } else {
+        set share [NetUseGetInfo "" $unc 2]
+    }
+    array set shareinfo [USE_INFO_2 $share]
+    unset shareinfo(-password)
+    if {[info exists shareinfo(-status)]} {
+        set shareinfo(-status) [_map_useinfo_status $shareinfo(-status)]
+    }
+    if {[info exists shareinfo(-type)]} {
+        set shareinfo(-type) [_map_useinfo_type $shareinfo(-type)]
+    }
+
+    if {$opts(-all) || $opts(-comment) || $opts(-provider)} {
+        # Only get this information if we are connected
+        if {$shareinfo(-status) eq "connected"} {
+            set wnetinfo [lindex [Twapi_WNetGetResourceInformation $unc "" 0] 0]
+            set shareinfo(-comment) [lindex $wnetinfo 6]
+            set shareinfo(-provider) [lindex $wnetinfo 7]
+        } else {
+            set shareinfo(-comment) ""
+            set shareinfo(-provider) ""
+        }
+    }
+
+    if {$opts(-all)} {
+        return [array get shareinfo]
+    }
+
+    # Get rid of unwanted fields
+    foreach opt {
+        -user
+        -localdevice
+        -remoteshare
+        -status
+        -type
+        -opencount
+        -usecount
+        -domain
+        -provider
+        -comment
+    } {
+        if {! $opts($opt)} {
+            unset -nocomplain shareinfo($opt)
+        }
+    }
+
+    return [array get shareinfo]
+}
+
+
+# Enumerate sessions
+proc twapi::find_lm_sessions args {
+    array set opts [parseargs args {
+        all
+        {matchclient.arg ""}
+        {system.arg ""}
+        {matchuser.arg ""}
+        transport
+        clientname
+        user
+        clienttype
+        opencount
+        idleseconds
+        activeseconds
+        attrs
+    } -maxleftover 0]
+
+    set level [_calc_minimum_session_info_level opts]
+    
+    # On all platforms, client must be in UNC format
+    set opts(matchclient) [_make_unc_computername $opts(matchclient)]
+
+    trap {
+        set sessions [_net_enum_helper NetSessionEnum -system $opts(system) -preargs [list $opts(matchclient) $opts(matchuser)] -level $level -fields [SESSION_INFO_$level]]
+    } onerror {TWAPI_WIN32 2312} {
+        # No session matching the specified client
+        set sessions {}
+    } onerror {TWAPI_WIN32 2221} {
+        # No session matching the user
+        set sessions {}
+    }
+
+    return [_format_lm_sessions $sessions opts]
+}
+
+
+# Get information about a session 
+proc twapi::get_lm_session_info {client user args} {
+    array set opts [parseargs args {
+        all
+        {system.arg ""}
+        transport
+        clientname
+        user
+        clienttype
+        opencount
+        idleseconds
+        activeseconds
+        attrs
+    } -maxleftover 0]
+
+    set level [_calc_minimum_session_info_level opts]
+    if {$level == -1} {
+        # No data requested so return empty list
+        return [list ]
+    }
+
+    if {![min_os_version 5]} {
+        # System name is specified. If NT, make sure it is UNC form
+        set opts(system) [_make_unc_computername $opts(system)]
+    }
+    
+    # On all platforms, client must be in UNC format
+    set client [_make_unc_computername $client]
+
+    # Note an error is generated if no matching session exists
+    set sess [NetSessionGetInfo $opts(system) $client $user $level]
+
+    return [recordarray index [_format_lm_sessions [list [SESSION_INFO_$level] [list $sess]] opts] 0 -format dict]
+}
+
+# Delete sessions
+proc twapi::end_lm_sessions args {
+    array set opts [parseargs args {
+        {client.arg ""}
+        {system.arg ""}
+        {user.arg ""}
+    } -maxleftover 0]
+
+    if {![min_os_version 5]} {
+        # System name is specified. If NT, make sure it is UNC form
+        set opts(system) [_make_unc_computername $opts(system)]
+    }
+
+    if {$opts(client) eq "" && $opts(user) eq ""} {
+        win32_error 87 "At least one of -client and -user must be specified."
+    }
+
+    # On all platforms, client must be in UNC format
+    set opts(client) [_make_unc_computername $opts(client)]
+
+    trap {
+        NetSessionDel $opts(system) $opts(client) $opts(user)
+    } onerror {TWAPI_WIN32 2312} {
+        # No session matching the specified client - ignore error
+    } onerror {TWAPI_WIN32 2221} {
+        # No session matching the user - ignore error
+    }
+    return
+}
+
+# Enumerate open files
+proc twapi::find_lm_open_files args {
+    array set opts [parseargs args {
+        {basepath.arg ""}
+        {system.arg ""}
+        {matchuser.arg ""}
+        all
+        permissions
+        id
+        lockcount
+        path
+        user
+    } -maxleftover 0]
+
+    set level 3
+    if {! ($opts(all) || $opts(permissions) || $opts(lockcount) ||
+           $opts(path) || $opts(user))} {
+        # Only id's required
+        set level 2
+    }
+
+    # TBD - change to use -resume option to _net_enum_helper as there
+    # might be a lot of files
+    trap {
+        set files [_net_enum_helper NetFileEnum -system $opts(system) -preargs [list [file nativename $opts(basepath)] $opts(matchuser)] -level $level -fields [FILE_INFO_$level]]
+    } onerror {TWAPI_WIN32 2221} {
+        # No files matching the user
+        set files [list [FILE_INFO_$level] {}]
+    }
+
+    return [_format_lm_open_files $files opts]
+}
+
+# Get information about an open LM file
+proc twapi::get_lm_open_file_info {fid args} {
+    array set opts [parseargs args {
+        {system.arg ""}
+        all
+        permissions
+        id
+        lockcount
+        path
+        user
+    } -maxleftover 0]
+
+    # System name is specified. If NT, make sure it is UNC form
+    if {![min_os_version 5]} {
+        set opts(system) [_make_unc_computername $opts(system)]
+    }
+    
+    set level 3
+    if {! ($opts(all) || $opts(permissions) || $opts(lockcount) ||
+           $opts(path) || $opts(user))} {
+        # Only id's required. We actually already have this but don't
+        # return it since we want to go ahead and make the call in case
+        # the id does not exist
+        set level 2
+    }
+
+    return [recordarray index [_format_lm_open_files [list [FILE_INFO_$level] [list [NetFileGetInfo $opts(system) $fid $level]]] opts] 0 -format dict]
+}
+
+# Close an open LM file
+proc twapi::close_lm_open_file {fid args} {
+    array set opts [parseargs args {
+        {system.arg ""}
+    } -maxleftover 0]
+    trap {
+        NetFileClose $opts(system) $fid
+    } onerror {TWAPI_WIN32 2314} {
+        # No such fid. Ignore, perhaps it was closed in the meanwhile
+    }
+}
+
+
+# Enumerate open connections
+proc twapi::find_lm_connections args {
+    array set opts [parseargs args {
+        client.arg
+        {system.arg ""}
+        share.arg
+        all
+        id
+        type
+        opencount
+        usercount
+        activeseconds
+        user
+        clientname
+        sharename
+    } -maxleftover 0]
+
+    if {! ([info exists opts(client)] || [info exists opts(share)])} {
+        win32_error 87 "Must specify either -client or -share option."
+    }
+
+    if {[info exists opts(client)] && [info exists opts(share)]} {
+        win32_error 87 "Must not specify both -client and -share options."
+    }
+
+    if {[info exists opts(client)]} {
+        set qualifier [_make_unc_computername $opts(client)]
+    } else {
+        set qualifier $opts(share)
+    }
+
+    set level 0
+    if {$opts(all) || $opts(type) || $opts(opencount) ||
+        $opts(usercount) || $opts(user) ||
+        $opts(activeseconds) || $opts(clientname) || $opts(sharename)} {
+        set level 1
+    }
+
+    # TBD - change to use -resume option to _net_enum_helper since
+    # there might be a log of connections
+    set conns [_net_enum_helper NetConnectionEnum -system $opts(system) -preargs [list $qualifier] -level $level -fields [CONNECTION_INFO_$level]]
+
+    # NOTE fields MUST BE IN SAME ORDER AS VALUES BELOW
+    if {! $opts(all)} {
+        set fields {}
+        foreach opt {id opencount usercount activeseconds user type} {
+            if {$opts(all) || $opts($opt)} {
+                lappend fields -$opt
+            }
+        }
+        if {$opts(all) || $opts(clientname) || $opts(sharename)} {
+            lappend fields -netname
+        }
+        set conns [recordarray get $conns -slice $fields]
+    }    
+    set fields [recordarray fields $conns]
+    if {"-type" in $fields} {
+        set type_enum [enum $fields -type]
+    }
+    if {"-netname" in $fields} {
+        set netname_enum [enum $fields -netname]
+    }
+
+    if {! ([info exists type_enum] || [info exists netname_enum])} {
+        # No need to massage any data
+        return $conns
+    }
+
+    set recs {}
+    foreach rec [recordarray getlist $conns] {
+        if {[info exists type_enum]} {
+            lset rec $type_enum [_share_type_code_to_symbols [lindex $rec $type_enum]]
+        }
+        if {[info exists netname_enum]} {
+            # What's returned in the netname field depends on what we
+            # passed as the qualifier
+            if {[info exists opts(client)]} {
+                set sharename [lindex $rec $netname_enum]
+                set clientname [_make_unc_computername $opts(client)]
+            } else {
+                set sharename $opts(share)
+                set clientname [_make_unc_computername [lindex $rec $netname_enum]]
+            }
+            if {$opts(all) || $opts(clientname)} {
+                lappend rec $clientname
+            }
+            if {$opts(all) || $opts(sharename)} {
+                lappend rec $sharename
+            }
+        }
+        lappend recs $rec
+    }
+    if {$opts(all) || $opts(clientname)} {
+        lappend fields -clientname
+    }
+    if {$opts(all) || $opts(sharename)} {
+        lappend fields -sharename
+    }
+
+    return [list $fields $recs]
+}
+
+proc twapi::wnet_connected_resources {args} {
+    # Accept both file/disk and print/printer for historical reasons
+    # file and printer are official to match get_client_share_info
+    parseargs args {
+        {type.sym any {any 0 file 1 disk 1 print 2 printer 2}}
+    } -maxleftover 0 -setvars
+    set h [WNetOpenEnum 1 $type 0 ""]
+    trap {
+        set resources {}
+        set structdef [twapi::NETRESOURCE]
+        while {[llength [set rs [WNetEnumResource $h 100 $structdef]]]} {
+            foreach r $rs {
+                lappend resources [lrange $r 4 5]
+            }
+        }
+    } finally {
+        WNetCloseEnum $h
+    }
+    return $resources
+}
+
+################################################################
+# Utility functions
+
+# Common code to figure out what SESSION_INFO level is required
+# for the specified set of requested fields. v_opts is name
+# of array indicating which fields are required
+proc twapi::_calc_minimum_session_info_level {v_opts} {
+    upvar $v_opts opts
+
+    # Set the information level requested based on options specified.
+    # We set the level to the one that requires the lowest possible
+    # privilege level and still includes the data requested.
+    if {$opts(all) || $opts(transport)} {
+        return 502
+    } elseif {$opts(clienttype)} {
+        return 2
+    } elseif {$opts(opencount) || $opts(attrs)} {
+        return 1
+    } elseif {$opts(clientname) || $opts(user) ||
+        $opts(idleseconds) || $opts(activeseconds)} {
+        return 10
+    } else {
+        return 0
+    }
+}
+
+# Common code to format a session record. v_opts is name of array
+# that controls which fields are returned
+# sessions is a record array
+proc twapi::_format_lm_sessions {sessions v_opts} {
+    upvar $v_opts opts
+
+    if {! $opts(all)} {
+        set fields {}
+        foreach opt {
+            transport user opencount idleseconds activeseconds
+            clienttype clientname attrs
+        } {
+            if {$opts(all) || $opts($opt)} {
+                lappend fields -$opt
+            }
+        }
+        set sessions [recordarray get $sessions -slice $fields]
+    }
+
+    set fields [recordarray fields $sessions]
+    if {"-clientname" in $fields} {
+        set client_enum [enum $fields -clientname]
+    }
+    if {"-attrs" in $fields} {
+        set attrs_enum [enum $fields -attrs]
+    }
+
+    if {! ([info exists client_enum] || [info exists attrs_enum])} {
+        return $sessions
+    }
+
+    # Need to map client name and attrs fields
+    set recs {}
+    foreach rec [recordarray getlist $sessions] {
+        if {[info exists client_enum]} {
+            lset rec $client_enum [_make_unc_computername [lindex $rec $client_enum]]
+        }
+        if {[info exists attrs_enum]} {
+            set attrs {}
+            set flags [lindex $rec $attrs_enum]
+            if {$flags & 1} {
+                lappend attrs guest
+            }
+            if {$flags & 2} {
+                lappend attrs noencryption
+            }
+            lset rec $attrs_enum $attrs
+        }
+        lappend recs $rec
+    }
+    return [list $fields $recs]
+}
+
+# Common code to format a lm open file record. v_opts is name of array
+# that controls which fields are returned
+proc twapi::_format_lm_open_files {files v_opts} {
+    upvar $v_opts opts
+
+    if {! $opts(all)} {
+        set fields {}
+        foreach opt {
+            id lockcount path user permissions
+        } {
+            if {$opts(all) || $opts($opt)} {
+                lappend fields -$opt
+            }
+        }
+        set files [recordarray get $files -slice $fields]
+    }
+
+    set fields [recordarray fields $files]
+
+    if {"-permissions" ni $fields} {
+        return $files
+    }
+
+    # Need to massage permissions
+    set enum [enum $fields -permissions]
+
+    set recs {}
+    foreach rec [recordarray getlist $files] {
+        set permissions [list ]
+        set perms [lindex $rec $enum]
+        foreach {flag perm} {1 read 2 write 4 create} {
+            if {$perms & $flag} {
+                lappend permissions $perm
+            }
+        }
+        lset rec $enum $permissions
+        lappend recs $rec
+    }
+
+    return [list $fields $recs]
+}
+
+# NOTE: THIS ONLY MAPS FOR THE Net* functions, NOT THE WNet*
+proc twapi::_share_type_symbols_to_code {typesyms {basetypeonly 0}} {
+
+    # STYPE_DISKTREE          0
+    # STYPE_PRINTQ            1
+    # STYPE_DEVICE            2
+    # STYPE_IPC               3
+    switch -exact -- [lindex $typesyms 0] {
+        file    { set code 0 }
+        printer { set code 1 }
+        device  { set code 2 }
+        ipc     { set code 3 }
+        default {
+            error "Unknown type network share type symbol [lindex $typesyms 0]"
+        }
+    }
+
+    if {$basetypeonly} {
+        return $code
+    }
+
+    # STYPE_TEMPORARY         0x40000000
+    # STYPE_SPECIAL           0x80000000
+    set special 0
+    foreach sym [lrange $typesyms 1 end] {
+        switch -exact -- $sym {
+            special   { setbits special 0x80000000 }
+            temporary { setbits special 0x40000000 }
+            file    -
+            printer -
+            device  -
+            ipc     {
+                error "Base share type symbol '$sym' cannot be used as a share attribute type"
+            }
+            default {
+                error "Unknown type network share type symbol '$sym'"
+            }
+        }
+    }
+
+    return [expr {$code | $special}]
+}
+
+
+# First element is always the base type of the share
+# NOTE: THIS ONLY MAPS FOR THE Net* functions, NOT THE WNet*
+proc twapi::_share_type_code_to_symbols {type} {
+
+    # STYPE_DISKTREE          0
+    # STYPE_PRINTQ            1
+    # STYPE_DEVICE            2
+    # STYPE_IPC               3
+    # STYPE_TEMPORARY         0x40000000
+    # STYPE_SPECIAL           0x80000000
+
+    set special [expr {$type & 0xC0000000}]
+
+    # We need the special cast to int because else operands get promoted
+    # to 64 bits as the hex is treated as an unsigned value
+    switch -exact -- [expr {int($type & ~ $special)}] {
+        0  {set sym "file"}
+        1  {set sym "printer"}
+        2  {set sym "device"}
+        3  {set sym "ipc"} 
+        default {set sym $type}
+    }
+
+    set typesyms [list $sym]
+
+    if {$special & 0x80000000} {
+        lappend typesyms special
+    }
+
+    if {$special & 0x40000000} {
+        lappend typesyms temporary
+    }
+    
+    return $typesyms
+}
+
+# Make sure a computer name is in unc format unless it is an empty
+# string (local computer)
+proc twapi::_make_unc_computername {name} {
+    if {$name eq ""} {
+        return ""
+    } else {
+        return "\\\\[string trimleft $name \\]"
+    }
+}
+
+proc twapi::_map_useinfo_status {status} {
+    set sym [lindex {connected paused lostsession disconnected networkerror connecting reconnecting} $status]
+    if {$sym ne ""} {
+        return $sym
+    } else {
+        return $status
+    }
+}
+
+proc twapi::_map_useinfo_type {type} {
+    # Note share type and use info types are different
+    return [_share_type_code_to_symbols [expr {$type & 0x3fffffff}]]
+}

src/punk86.vfs/lib/twapi4.7.2/shell.tcl

@@ -0,0 +1,627 @@
+#
+# Copyright (c) 2004-2011 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {}
+
+
+# Get the specified shell folder
+proc twapi::get_shell_folder {csidl args} {
+    variable csidl_lookup
+
+    array set opts [parseargs args {create} -maxleftover 0]
+
+    # Following are left out because they refer to virtual folders
+    # and will return error if used here
+    #    CSIDL_BITBUCKET - 0xa
+    if {![info exists csidl_lookup]} {
+        array set csidl_lookup {
+            CSIDL_ADMINTOOLS 0x30
+            CSIDL_COMMON_ADMINTOOLS 0x2f
+            CSIDL_APPDATA 0x1a
+            CSIDL_COMMON_APPDATA 0x23
+            CSIDL_COMMON_DESKTOPDIRECTORY 0x19
+            CSIDL_COMMON_DOCUMENTS 0x2e
+            CSIDL_COMMON_FAVORITES 0x1f
+            CSIDL_COMMON_MUSIC 0x35
+            CSIDL_COMMON_PICTURES 0x36
+            CSIDL_COMMON_PROGRAMS 0x17
+            CSIDL_COMMON_STARTMENU 0x16
+            CSIDL_COMMON_STARTUP 0x18
+            CSIDL_COMMON_TEMPLATES 0x2d
+            CSIDL_COMMON_VIDEO 0x37
+            CSIDL_COOKIES 0x21
+            CSIDL_DESKTOPDIRECTORY 0x10
+            CSIDL_FAVORITES 0x6
+            CSIDL_HISTORY 0x22
+            CSIDL_INTERNET_CACHE 0x20
+            CSIDL_LOCAL_APPDATA 0x1c
+            CSIDL_MYMUSIC 0xd
+            CSIDL_MYPICTURES 0x27
+            CSIDL_MYVIDEO 0xe
+            CSIDL_NETHOOD 0x13
+            CSIDL_PERSONAL 0x5
+            CSIDL_PRINTHOOD 0x1b
+            CSIDL_PROFILE 0x28
+            CSIDL_PROFILES 0x3e
+            CSIDL_PROGRAMS 0x2
+            CSIDL_PROGRAM_FILES 0x26
+            CSIDL_PROGRAM_FILES_COMMON 0x2b
+            CSIDL_RECENT 0x8
+            CSIDL_SENDTO 0x9
+            CSIDL_STARTMENU 0xb
+            CSIDL_STARTUP 0x7
+            CSIDL_SYSTEM 0x25
+            CSIDL_TEMPLATES 0x15
+            CSIDL_WINDOWS 0x24
+            CSIDL_CDBURN_AREA 0x3b
+        }
+    }
+
+    if {![string is integer $csidl]} {
+        set csidl_key [string toupper $csidl]
+        if {![info exists csidl_lookup($csidl_key)]} {
+            # Try by adding a CSIDL prefix
+            set csidl_key "CSIDL_$csidl_key"
+            if {![info exists csidl_lookup($csidl_key)]} {
+                error "Invalid CSIDL value '$csidl'"
+            }
+        }
+        set csidl $csidl_lookup($csidl_key)
+    }
+
+    trap {
+        set path [SHGetSpecialFolderPath 0 $csidl $opts(create)]
+    } onerror {} {
+        # Try some other way to get the information
+        switch -exact -- [format %x $csidl] {
+            1a { catch {set path $::env(APPDATA)} }
+            2b { catch {set path $::env(CommonProgramFiles)} }
+            26 { catch {set path $::env(ProgramFiles)} }
+            24 { catch {set path $::env(windir)} }
+            25 { catch {set path [file join $::env(systemroot) system32]} }
+        }
+        if {![info exists path]} {
+            return ""
+        }
+    }
+
+    return $path
+}
+
+# Displays a shell property dialog for the given object
+proc twapi::shell_object_properties_dialog {path args} {
+    array set opts [parseargs args {
+        {type.arg file {file printer volume}}
+        {hwin.int 0}
+        {page.arg ""}
+    } -maxleftover 0]
+
+
+    if {$opts(type) eq "file"} {
+        set path [file nativename [file normalize $path]]
+    }
+
+    SHObjectProperties $opts(hwin) \
+        [string map {printer 1 file 2 volume 4} $opts(type)] \
+        $path \
+        $opts(page)
+}
+
+# Writes a shell shortcut
+proc twapi::write_shortcut {link args} {
+    
+    array set opts [parseargs args {
+        path.arg
+        idl.arg
+        args.arg
+        desc.arg
+        hotkey.arg
+        iconpath.arg
+        iconindex.int
+        {showcmd.arg normal}
+        workdir.arg
+        relativepath.arg
+        runas.bool
+    } -nulldefault -maxleftover 0]
+
+    # Map hot key to integer if needed
+    if {![string is integer -strict $opts(hotkey)]} {
+        if {$opts(hotkey) eq ""} {
+            set opts(hotkey) 0
+        } else {
+            # Try treating it as symbolic
+            lassign [_hotkeysyms_to_vk $opts(hotkey)]  modifiers vk
+            set opts(hotkey) $vk
+            if {$modifiers & 1} {
+                set opts(hotkey) [expr {$opts(hotkey) | (4<<8)}]
+            }
+            if {$modifiers & 2} {
+                set opts(hotkey) [expr {$opts(hotkey) | (2<<8)}]
+            }
+            if {$modifiers & 4} {
+                set opts(hotkey) [expr {$opts(hotkey) | (1<<8)}]
+            }
+            if {$modifiers & 8} {
+                set opts(hotkey) [expr {$opts(hotkey) | (8<<8)}]
+            }
+        }
+    }
+
+    # IF a known symbol translate it. Note caller can pass integer
+    # values as well which will be kept as they are. Bogus valuse and
+    # symbols will generate an error on the actual call so we don't
+    # check here.
+    switch -exact -- $opts(showcmd) {
+        minimized { set opts(showcmd) 7 }
+        maximized { set opts(showcmd) 3 }
+        normal    { set opts(showcmd) 1 }
+    }
+
+    Twapi_WriteShortcut $link $opts(path) $opts(idl) $opts(args) \
+        $opts(desc) $opts(hotkey) $opts(iconpath) $opts(iconindex) \
+        $opts(relativepath) $opts(showcmd) $opts(workdir) $opts(runas)
+}
+
+
+# Read a shortcut
+proc twapi::read_shortcut {link args} {
+    array set opts [parseargs args {
+        timeout.int
+        {hwin.int 0}
+
+        {_comment {Path format flags}}
+        {shortnames {} 1}
+        {uncpath    {} 2}
+        {rawpath    {} 4}
+
+        {_comment {Resolve flags}}
+        {install {} 128}
+        {nolinkinfo {} 64}
+        {notrack {} 32}
+        {nosearch {} 16}
+        {anymatch {} 2}
+        {noui {} 1}
+    } -maxleftover 0]
+
+    set pathfmt [expr {$opts(shortnames) | $opts(uncpath) | $opts(rawpath)}]
+
+    # 4 -> SLR_UPDATE
+    set resolve_flags [expr {4 | $opts(install) | $opts(nolinkinfo) |
+                             $opts(notrack) | $opts(nosearch) |
+                             $opts(anymatch) | $opts(noui)}]
+
+    array set shortcut [twapi::Twapi_ReadShortcut $link $pathfmt $opts(hwin) $resolve_flags]
+
+    switch -exact -- $shortcut(-showcmd) {
+        1 { set shortcut(-showcmd) normal }
+        3 { set shortcut(-showcmd) maximized }
+        7 { set shortcut(-showcmd) minimized }
+    }
+
+    return [array get shortcut]
+}
+
+
+
+# Writes a url shortcut
+proc twapi::write_url_shortcut {link url args} {
+    
+    array set opts [parseargs args {
+        {missingprotocol.arg 0}
+    } -nulldefault -maxleftover 0]
+
+    switch -exact -- $opts(missingprotocol) {
+        guess {
+            set opts(missingprotocol) 1; # IURL_SETURL_FL_GUESS_PROTOCOL
+        }
+        usedefault {
+            # 3 -> IURL_SETURL_FL_GUESS_PROTOCOL | IURL_SETURL_FL_USE_DEFAULT_PROTOCOL
+            # The former must also be specified (based on experimentation)
+            set opts(missingprotocol) 3
+        }
+        default {
+            if {![string is integer -strict $opts(missingprotocol)]} {
+                error "Invalid value '$opts(missingprotocol)' for -missingprotocol option."
+            }
+        }
+    }
+
+    Twapi_WriteUrlShortcut $link $url $opts(missingprotocol)
+}
+
+# Read a url shortcut
+proc twapi::read_url_shortcut {link} {
+    return [Twapi_ReadUrlShortcut $link]
+}
+
+# Invoke a url shortcut
+proc twapi::invoke_url_shortcut {link args} {
+    
+    array set opts [parseargs args {
+        verb.arg
+        {hwin.int 0}
+        allowui
+    } -maxleftover 0]
+
+    set flags 0
+    if {$opts(allowui)} {setbits flags 1}
+    if {! [info exists opts(verb)]} {
+        setbits flags 2
+        set opts(verb) ""
+    }
+
+    Twapi_InvokeUrlShortcut $link $opts(verb) $flags $opts(hwin)
+}
+
+# Send a file to the recycle bin
+proc twapi::recycle_file {fn args} {
+    return [recycle_files [list $fn] {*}$args]
+}
+
+# Send multiple files to the recycle bin - from Alexandru
+# This is much faster than "recycle_file"!
+proc twapi::recycle_files {fns args} {
+    array set opts [parseargs args {
+        confirm.bool
+        showerror.bool
+    } -maxleftover 0 -nulldefault]
+
+    if {$opts(confirm)} {
+        set flags 0x40;         # FOF_ALLOWUNDO
+    } else {
+        set flags 0x50;         # FOF_ALLOWUNDO | FOF_NOCONFIRMATION
+    }
+
+    if {! $opts(showerror)} {
+        set flags [expr {$flags | 0x0400}]; # FOF_NOERRORUI
+    }
+
+    set fns [lmap fn $fns {
+        file nativename [file normalize $fn]
+    }]
+
+    return [expr {[lindex [Twapi_SHFileOperation 0 3 $fns __null__ $flags ""] 0] ? false : true}]
+}
+
+proc twapi::shell_execute args {
+    # TBD - Document following shell_execute options after testing.
+    # [opt_def [cmd -connect] [arg BOOLEAN]]
+    # [opt_def [cmd -hicon] [arg HANDLE]]
+    # [opt_def [cmd -hkeyclass] [arg BOOLEAN]]
+    # [opt_def [cmd -hotkey] [arg HOTKEY]]
+    # [opt_def [cmd -nozonechecks] [arg BOOLEAN]]
+
+    array set opts [parseargs args {
+        class.arg
+        dir.arg
+        {hicon.arg NULL}
+        {hkeyclass.arg NULL}
+        {hmonitor.arg NULL}
+        hotkey.arg
+        hwin.int
+        idl.arg
+        params.arg
+        path.arg
+        {show.arg 1}
+        verb.arg
+
+        {getprocesshandle.bool 0 0x00000040}
+        {connect.bool 0 0x00000080}
+        {wait.bool 0x00000100 0x00000100}
+        {substenv.bool 0 0x00000200}
+        {noui.bool 0 0x00000400}
+        {unicode.bool 0 0x00004000}
+        {noconsole.bool 0 0x00008000}
+        {asyncok.bool 0 0x00100000}
+        {nozonechecks.bool 0 0x00800000}
+        {waitforinputidle.bool 0 0x02000000}
+        {logusage.bool 0 0x04000000}
+        {invokeidlist.bool 0 0x0000000C}
+    } -maxleftover 0 -nulldefault]
+
+    set fmask 0
+
+    foreach {opt mask} {
+        class     1
+        idl       4
+    } {
+        if {$opts($opt) ne ""} {
+            setbits fmask $mask
+        }
+    }
+
+    if {$opts(hkeyclass) ne "NULL"} {
+        setbits fmask 3
+    }
+
+    set fmask [expr {$fmask |
+                     $opts(getprocesshandle) | $opts(connect) | $opts(wait) |
+                     $opts(substenv) | $opts(noui) | $opts(unicode) |
+                     $opts(noconsole) | $opts(asyncok) | $opts(nozonechecks) |
+                     $opts(waitforinputidle) | $opts(logusage) |
+                     $opts(invokeidlist)}]
+
+    if {$opts(hicon) ne "NULL" && $opts(hmonitor) ne "NULL"} {
+        error "Cannot specify -hicon and -hmonitor options together."
+    }
+
+    set hiconormonitor NULL
+    if {$opts(hicon) ne "NULL"} {
+        set hiconormonitor $opts(hicon)
+        set flags [expr {$flags | 0x00000010}]
+    } elseif {$opts(hmonitor) ne "NULL"} {
+        set hiconormonitor $opts(hmonitor)
+        set flags [expr {$flags | 0x00200000}]
+    }
+
+    if {![string is integer -strict $opts(show)]} {
+        set opts(show) [dict get {
+            hide             0
+            shownormal       1
+            normal           1
+            showminimized    2
+            showmaximized    3
+            maximize         3
+            shownoactivate   4
+            show             5
+            minimize         6
+            showminnoactive  7
+            showna           8
+            restore          9
+            showdefault      10
+            forceminimize    11
+        } $opts(show)]
+    }
+
+    if {$opts(hotkey) eq ""} {
+        set hotkey 0
+    } else {
+        lassign [_hotkeysyms_to_vk $opts(hotkey) {
+            shift 1
+            ctrl 2
+            control 2
+            alt 4
+            menu 4
+            ext 8
+        }] modifiers vk
+        set hotkey [expr {($modifiers << 16) | $vk}]
+    }
+    if {$hotkey != 0} {
+        setbits fmask 0x00000020
+    }
+    return [Twapi_ShellExecuteEx \
+                $fmask \
+                $opts(hwin) \
+                $opts(verb) \
+                $opts(path) \
+                $opts(params) \
+                $opts(dir) \
+                $opts(show) \
+                $opts(idl) \
+                $opts(class) \
+                $opts(hkeyclass) \
+                $hotkey \
+                $hiconormonitor]
+}
+
+
+namespace eval twapi::systemtray {
+
+    namespace path [namespace parent]
+
+    # Dictionary mapping id->handler, hicon
+    variable _icondata
+    set _icondata [dict create]
+
+    variable _icon_id_ctr
+
+    variable _message_map
+    array set _message_map {
+        123 contextmenu
+        512 mousemove
+        513 lbuttondown
+        514 lbuttonup
+        515 lbuttondblclk
+        516 rbuttondown
+        517 rbuttonup
+        518 rbuttondblclk
+        519 mbuttondown
+        520 mbuttonup
+        521 mbuttondblclk
+        522 mousewheel
+        523 xbuttondown
+        524 xbuttonup
+        525 xbuttondblclk
+        1024 select
+        1025 keyselect
+        1026 balloonshow
+        1027 balloonhide
+        1028 balloontimeout
+        1029 balloonuserclick
+    }
+
+    proc _make_NOTIFYICONW {id args} {
+        # TBD - implement -hiddenicon and -sharedicon using
+        # dwState and dwStateMask
+        set state     0
+        set statemask 0
+        array set opts [parseargs args {
+            hicon.arg
+            tip.arg
+            balloon.arg
+            timeout.int
+            version.int
+            balloontitle.arg
+            {balloonicon.arg none {info warning error user none}}
+            {silent.bool 0}
+        } -maxleftover 0]
+
+        set timeout_or_version 0
+        if {[info exists opts(version)]} {
+            if {[info exists opts(timeout)]} {
+                error "Cannot simultaneously specify -timeout and -version."
+            }
+            set timeout_or_version $opts(version)
+        } else {
+            if {[info exists opts(timeout)]} {
+                set timeout_or_version $opts(timeout)
+            }
+        }
+
+        set flags 0x1;          # uCallbackMessage member is valid
+        if {[info exists opts(hicon)]} {
+            incr flags 0x2;     # hIcon member is valid
+        } else {
+            set opts(hicon) NULL
+        }
+
+        if {[info exists opts(tip)]} {
+            incr flags 0x4
+            # Truncate if necessary to 127 chars
+            set opts(tip) [string range $opts(tip) 0 127]
+        } else {
+            set opts(tip) ""
+        }
+
+        if {[info exists opts(balloon)] || [info exists opts(balloontitle)]} {
+            incr flags 0x10
+        }
+
+        if {[info exists opts(balloon)]} {
+            set opts(balloon) [string range $opts(balloon) 0 255]
+        } else {
+            set opts(balloon) ""
+        }
+
+        if {[info exists opts(balloontitle)]} {
+            set opts(balloontitle) [string range $opts(balloontitle) 0 63]
+        } else {
+            set opts(balloontitle) ""
+        }
+
+        # Calculate padding for text fields (in bytes so 2*num padchars)
+        set tip_padcount [expr {2*(128 - [string length $opts(tip)])}]
+        set balloon_padcount [expr {2*(256 - [string length $opts(balloon)])}]
+        set balloontitle_padcount [expr {2 * (64 - [string length $opts(balloontitle)])}]
+        if {$opts(balloonicon) eq "user"} {
+            if {![min_os_version 5 1 2]} {
+                # 'user' not supported before XP SP2
+                set opts(balloonicon) none
+            }
+        }
+
+        set balloonflags [dict get {
+            none 0
+            info 1
+            warning 2
+            error 3
+            user 4
+        } $opts(balloonicon)]
+        
+        if {$balloonflags == 4} {
+            if {![info exists opts(hicon)]} {
+                error "Option -hicon must be specified if value of -balloonicon option is 'user'"
+            }
+        }
+
+        if {$opts(silent)} {
+            incr balloonflags 0x10
+        }
+
+        if {$::tcl_platform(pointerSize) == 8} {
+            set addrfmt m
+            set alignment x4
+        } else {
+            set addrfmt n
+            set alignment x0
+        }
+
+        set hwnd  [pointer_to_address [Twapi_GetNotificationWindow]]
+        set opts(hicon) [pointer_to_address $opts(hicon)]
+
+        set bin [binary format "${alignment}${addrfmt}nnn" $hwnd $id $flags [_get_script_wm NOTIFY_ICON_CALLBACK]]
+        append bin \
+            [binary format ${alignment}${addrfmt} $opts(hicon)] \
+            [encoding convertto unicode $opts(tip)] \
+            [binary format "x${tip_padcount}nn" $state $statemask] \
+            [encoding convertto unicode $opts(balloon)] \
+            [binary format "x${balloon_padcount}n" $timeout_or_version] \
+            [encoding convertto unicode $opts(balloontitle)] \
+            [binary format "x${balloontitle_padcount}nx16" $balloonflags]
+        return "[binary format n [expr {4+[string length $bin]}]]$bin"
+    }
+
+    proc addicon {hicon {cmdprefix ""}} {
+        variable _icon_id_ctr
+        variable _icondata
+
+        _register_script_wm_handler [_get_script_wm NOTIFY_ICON_CALLBACK] [list [namespace current]::_icon_handler] 1
+        _register_script_wm_handler [_get_script_wm TASKBAR_RESTART] [list [namespace current]::_taskbar_restart_handler] 1
+
+        set id [incr _icon_id_ctr]
+
+        # 0 -> Add
+        Shell_NotifyIcon 0 [_make_NOTIFYICONW $id -hicon $hicon]
+
+        # 4 -> set version (controls notification behaviour) to 3 (Win2K+)
+        if {[catch {
+            Shell_NotifyIcon 4 [_make_NOTIFYICONW $id -version 3]
+        } ermsg]} {
+            set ercode $::errorCode
+            set erinfo $::errorInfo
+            removeicon $id
+            error $ermsg $erinfo $ercode
+        }
+
+        if {[llength $cmdprefix]} {
+            dict set _icondata $id handler $cmdprefix
+        }
+        dict set _icondata $id hicon   $hicon
+
+        return $id
+    }
+
+    proc removeicon {id} {
+        variable _icondata
+
+        # Ignore errors in case dup call
+        catch {Shell_NotifyIcon 2 [_make_NOTIFYICONW $id]}
+        dict unset _icondata $id
+    }
+
+    proc modifyicon {id args} {
+        # TBD - do we need to [dict set _icondata hicon ...] ?
+        Shell_NotifyIcon 1 [_make_NOTIFYICONW $id {*}$args]
+    }
+
+    proc _icon_handler {msg id notification msgpos ticks} {
+        variable _icondata
+        variable _message_map
+
+        if {![dict  exists $_icondata $id handler]} {
+            return;             # Stale or no handler specified
+        }
+
+        # Translate the notification into text
+        if {[info exists _message_map($notification)]} {
+            set notification $_message_map($notification)
+        }
+        
+        uplevel #0 [linsert [dict get $_icondata $id handler] end $id $notification $msgpos $ticks]
+    }
+
+    proc _taskbar_restart_handler {args} {
+        variable _icondata
+        # Need to add icons back into taskbar
+        dict for {id icodata} $_icondata {
+            # 0 -> Add
+            Shell_NotifyIcon 0 [_make_NOTIFYICONW $id -hicon [dict get $icodata hicon]]
+        }
+    }
+
+    namespace export addicon modifyicon removeicon
+    namespace ensemble create
+}

src/punk86.vfs/lib/twapi4.7.2/sspi.tcl

@@ -0,0 +1,801 @@
+#
+# Copyright (c) 2007-2013, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+namespace eval twapi {
+
+
+    # Holds SSPI security contexts indexed by a handle
+    # Each element is a dict with the following keys:
+    #   State - state of the security context - see sspi_step
+    #   Handle - the Win32 SecHandle for the context
+    #   Input - Pending input from remote end to be passed in to
+    #    SSPI provider (only valid for streams)
+    #   Output - list of SecBuffers that contain data to be sent
+    #    to remote end during a SSPI negotiation
+    #   Inattr - requested context attributes
+    #   Outattr - context attributes returned from service provider
+    #    (currently not used)
+    #   Expiration - time when context will expire
+    #   Ctxtype - client, server
+    #   Target -
+    #   Datarep - data representation format
+    #   Credentials - handle for credentials to pass to sspi provider
+    variable _sspi_state
+    array set _sspi_state {}
+
+    proc* _init_security_context_syms {} {
+        variable _server_security_context_syms
+        variable _client_security_context_syms
+        variable _secpkg_capability_syms
+
+
+        # Symbols used for mapping server security context flags
+        array set _server_security_context_syms {
+            confidentiality      0x10
+            connection           0x800
+            delegate             0x1
+            extendederror        0x8000
+            identify             0x80000
+            integrity            0x20000
+            mutualauth           0x2
+            replaydetect         0x4
+            sequencedetect       0x8
+            stream               0x10000
+        }
+
+        # Symbols used for mapping client security context flags
+        array set _client_security_context_syms {
+            confidentiality      0x10
+            connection           0x800
+            delegate             0x1
+            extendederror        0x4000
+            identify             0x20000
+            integrity            0x10000
+            manualvalidation     0x80000
+            mutualauth           0x2
+            replaydetect         0x4
+            sequencedetect       0x8
+            stream               0x8000
+            usesessionkey        0x20
+            usesuppliedcreds     0x80
+        }
+
+        # Symbols used for mapping security package capabilities
+        array set _secpkg_capability_syms {
+            integrity                   0x00000001
+            privacy                     0x00000002
+            tokenonly                  0x00000004
+            datagram                    0x00000008
+            connection                  0x00000010
+            multirequired              0x00000020
+            clientonly                 0x00000040
+            extendederror              0x00000080
+            impersonation               0x00000100
+            acceptwin32name           0x00000200
+            stream                      0x00000400
+            negotiable                  0x00000800
+            gsscompatible              0x00001000
+            logon                       0x00002000
+            asciibuffers               0x00004000
+            fragment                    0x00008000
+            mutualauth                 0x00010000
+            delegation                  0x00020000
+            readonlywithchecksum      0x00040000
+            restrictedtokens           0x00080000
+            negoextender               0x00100000
+            negotiable2                 0x00200000
+            appcontainerpassthrough  0x00400000
+            appcontainerchecks  0x00800000
+        }
+    } {}
+}
+
+# Return list of security packages
+proc twapi::sspi_enumerate_packages {args} {
+    set pkgs [EnumerateSecurityPackages]
+    if {[llength $args] == 0} {
+        set names [list ]
+        foreach pkg $pkgs {
+            lappend names [kl_get $pkg Name]
+        }
+        return $names
+    }
+
+    # TBD - why is this hyphenated ?
+    array set opts [parseargs args {
+        all capabilities version rpcid maxtokensize name comment
+    } -maxleftover 0 -hyphenated]
+
+    _init_security_context_syms
+    variable _secpkg_capability_syms
+    set retdata {}
+    foreach pkg $pkgs {
+        set rec {}
+        if {$opts(-all) || $opts(-capabilities)} {
+            lappend rec -capabilities [_make_symbolic_bitmask [kl_get $pkg fCapabilities] _secpkg_capability_syms]
+        }
+        foreach {opt field} {-version wVersion -rpcid wRPCID -maxtokensize cbMaxToken -name Name -comment Comment} {
+            if {$opts(-all) || $opts($opt)} {
+                lappend rec $opt [kl_get $pkg $field]
+            }
+        }
+        dict set recdata [kl_get $pkg Name] $rec
+    }
+    return $recdata
+}
+
+proc twapi::sspi_schannel_credentials args {
+    # TBD - do all these options work ? Check before documenting
+    # since they seem to be duplicated in InitializeSecurityContext
+    parseargs args {
+        certificates.arg
+        {rootstore.arg NULL}
+        sessionlifespan.int
+        usedefaultclientcert.bool
+        {disablereconnects.bool 0 0x80}
+        {revocationcheck.arg none {full endonly excluderoot none}}
+        {ignoreerrorrevocationoffline.bool 0 0x1000}
+        {ignoreerrornorevocationcheck.bool 0 0x800}
+        {validateservercert.bool 1}
+        cipherstrength.arg
+        protocols.arg
+    } -setvars -nulldefault -maxleftover 0
+
+    set flags [expr {$disablereconnects | $ignoreerrornorevocationcheck | $ignoreerrorrevocationoffline}]
+    incr flags [dict get {
+        none 0 full 0x200 excluderoot 0x400 endonly 0x100
+    } $revocationcheck]
+        
+    if {$validateservercert} {
+        incr flags 0x20;        # SCH_CRED_AUTO_CRED_VALIDATION
+    } else {
+        incr flags 0x8;         # SCH_CRED_MANUAL_CRED_VALIDATION
+    }
+    if {$usedefaultclientcert} {
+        incr flags 0x40;         # SCH_CRED_USE_DEFAULT_CREDS
+    } else {
+        incr flags 0x10;         # SCH_CRED_NO_DEFAULT_CREDS 
+    }
+
+    set protbits 0
+    foreach prot $protocols {
+        set protbits [expr {
+                            $protbits | [dict! {
+                                ssl2 0xc ssl3 0x30 tls1 0xc0 tls1.1 0x300 tls1.2 0xc00
+                            } $prot]
+                        }]
+    }
+
+    switch [llength $cipherstrength] {
+        0 { set minbits 0 ; set maxbits 0 }
+        1 { set minbits [lindex $cipherstrength 0] ; set maxbits $minbits }
+        2 {
+            set minbits [lindex $cipherstrength 0]
+            set maxbits [lindex $cipherstrength 1]
+        }
+        default {
+            error "Invalid value '$cipherstrength' for option -cipherstrength"
+        }
+    }
+
+    # 4 -> SCHANNEL_CRED_VERSION
+    return [list 4 $certificates $rootstore {} {} $protbits $minbits $maxbits $sessionlifespan $flags 0]
+}
+
+proc twapi::sspi_winnt_identity_credentials {user domain password} {
+    return [list $user $domain $password]
+}
+
+proc twapi::sspi_acquire_credentials {args} {
+    parseargs args {
+        {credentials.arg {}}
+        principal.arg
+        {package.arg NTLM}
+        {role.arg both {client server inbound outbound both}}
+        getexpiration
+    } -maxleftover 0 -setvars -nulldefault
+
+    set creds [AcquireCredentialsHandle $principal \
+                   [dict* {
+                       unisp {Microsoft Unified Security Protocol Provider}
+                       ssl {Microsoft Unified Security Protocol Provider}
+                       tls {Microsoft Unified Security Protocol Provider}
+                   } $package] \
+                   [kl_get {inbound 1 server 1 outbound 2 client 2 both 3} $role] \
+                   "" $credentials]
+
+    if {$getexpiration} {
+        return [kl_create2 {-handle -expiration} $creds]
+    } else {
+        return [lindex $creds 0]
+    }
+}
+
+# Frees credentials
+proc twapi::sspi_free_credentials {cred} {
+    FreeCredentialsHandle $cred
+}
+
+# Return a client context
+proc twapi::sspi_client_context {cred args} {
+    _init_security_context_syms
+    variable _client_security_context_syms
+
+    parseargs args {
+        target.arg
+        {datarep.arg network {native network}}
+        confidentiality.bool
+        connection.bool
+        delegate.bool
+        extendederror.bool
+        identify.bool
+        integrity.bool
+        manualvalidation.bool
+        mutualauth.bool
+        replaydetect.bool
+        sequencedetect.bool
+        stream.bool
+        usesessionkey.bool
+        usesuppliedcreds.bool
+    } -maxleftover 0 -nulldefault -setvars
+
+    set context_flags 0
+    foreach {opt flag} [array get _client_security_context_syms] {
+        if {[set $opt]} {
+            set context_flags [expr {$context_flags | $flag}]
+        }
+    }
+
+    set drep [kl_get {native 0x10 network 0} $datarep]
+    return [_construct_sspi_security_context \
+                sspiclient#[TwapiId] \
+                [InitializeSecurityContext \
+                     $cred \
+                     "" \
+                     $target \
+                     $context_flags \
+                     0 \
+                     $drep \
+                     [list ] \
+                     0] \
+                client \
+                $context_flags \
+                $target \
+                $cred \
+                $drep \
+               ]
+}
+
+# Delete a security context
+proc twapi::sspi_delete_context {ctx} {
+    variable _sspi_state
+    set h [_sspi_context_handle $ctx]
+    if {[llength $h]} {
+        DeleteSecurityContext $h
+    }
+    unset _sspi_state($ctx)
+}
+
+# Shuts down a security context in orderly fashion
+# Caller should start sspi_step
+proc twapi::sspi_shutdown_context {ctx} {
+    variable _sspi_state
+
+    _sspi_context_handle $ctx;  # Verify handle
+    dict with _sspi_state($ctx) {
+        switch -nocase -- [lindex [QueryContextAttributes $Handle 10] 4] {
+            schannel - 
+            "Microsoft Unified Security Protocol Provider" {}
+            default { return }
+        }
+
+        # Signal to security provider we want to shutdown
+        Twapi_ApplyControlToken_SCHANNEL_SHUTDOWN $Handle
+
+        if {$Ctxtype eq "client"} {
+            set rawctx [InitializeSecurityContext \
+                            $Credentials \
+                            $Handle \
+                            $Target \
+                            $Inattr \
+                            0 \
+                            $Datarep \
+                            [list ] \
+                            0]
+        } else {
+            set rawctx [AcceptSecurityContext \
+                            $Credentials \
+                            $Handle \
+                            [list ] \
+                            $Inattr \
+                            $Datarep]
+        }
+        lassign $rawctx State Handle out Outattr Expiration extra
+        if {$State in {ok expired}} {
+            return [list done [_gather_secbuf_data $out]]
+        } else {
+            return [list continue [_gather_secbuf_data $out]]
+        }
+    }
+}
+
+# Take the next step in an SSPI negotiation
+# Returns
+#   {done data extradata}
+#   {continue data}
+#   {expired data}
+proc twapi::sspi_step {ctx {received ""}} {
+    variable _sspi_state
+    variable _client_security_context_syms
+
+    _sspi_validate_handle $ctx
+
+    dict with _sspi_state($ctx) {
+        # Note the dictionary content variables are
+        #   State, Handle, Output, Outattr, Expiration,
+        #   Ctxtype, Inattr, Target, Datarep, Credentials
+
+        # Append new input to existing input
+        append Input $received
+        switch -exact -- $State {
+            ok {
+                set data [_gather_secbuf_data $Output]
+                set Output {}
+
+                # $Input at this point contains left over input that is
+                # actually application data (streaming case).
+                # Application should pass this to decrypt commands
+                return [list done $data $Input[set Input ""]]
+            }
+            continue {
+                # Continue with the negotiation
+                if {[string length $Input] != 0} {
+                    # Pass in received data to SSPI.
+                    # Most providers take only the first buffer
+                    # but SChannel/UNISP need the second. Since
+                    # others don't seem to mind the second buffer
+                    # we always always include it
+                    # 2 -> SECBUFFER_TOKEN, 0 -> SECBUFFER_EMPTY
+                    set inbuflist [list [list 2 $Input] [list 0]]
+                    if {$Ctxtype eq "client"} {
+                        set rawctx [InitializeSecurityContext \
+                                        $Credentials \
+                                        $Handle \
+                                        $Target \
+                                        $Inattr \
+                                        0 \
+                                        $Datarep \
+                                        $inbuflist \
+                                        0]
+                    } else {
+                        set rawctx [AcceptSecurityContext \
+                                        $Credentials \
+                                        $Handle \
+                                        $inbuflist \
+                                        $Inattr \
+                                        $Datarep]
+                    }
+                    lassign $rawctx State Handle out Outattr Expiration extra
+                    lappend Output {*}$out
+                    # When the error is incomplete_credentials, we will retry
+                    # with the SEC_I_INCOMPLETE_CREDENTIALS flag set. For
+                    # this the Input should remain the same. Otherwise set it
+                    # to whatever remains to be processed in the buffer.
+                    if {$State ne "incomplete_credentials"} {
+                        set Input $extra
+                    }
+                    # Will recurse at proc end
+                } else {
+                    # There was no received data. Return any data
+                    # to be sent to remote end
+                    set data [_gather_secbuf_data $Output]
+                    set Output {}
+                    return [list continue $data ""]
+                }
+            }
+            incomplete_message {
+                # Caller has to get more data from remote end
+                set State continue
+                return [list continue "" ""]
+            }
+            expired {
+                # Remote end closed in middle of negotiation
+                return [list disconnected "" ""]
+            }
+            incomplete_credentials {
+                # In this state, the remote has asked for an client certificate.
+                # In this case, we ask Schannel to limit itself to whatever
+                # the user supplied and retry. Servers that ask for a cert
+                # but do not mandate it will then proceed. However, we only
+                # do this if we have not already tried this route. If we have,
+                # then generate an error. The real solution would be to attempt
+                # to look up new credentials by retrieving a certificate
+                # from the certificate store (possibly by asking the user) but
+                # this is not implemented.
+                # TBD - get client cert from user. See
+                # https://github.com/david-maw/StreamSSL and
+                # https://www.codeproject.com/Articles/1094525/Configuring-SSL-and-Client-Certificate-Validation
+                if {$Inattr & $_client_security_context_syms(usesuppliedcreds)} {
+                    # Already tried with this. Give up.
+                    set ermsg "Handling of incomplete credentials not implemented. If using TLS, specify the -credentials option to tls_socket to provide credentials."
+                    error $ermsg "" [list TWAPI SSPI UNSUPPORTED $ermsg]
+                }
+                set Inattr [expr {$Inattr | $_client_security_context_syms(usesuppliedcreds)}]
+                set State continue
+                # Fall to bottom to recurse one more time
+            }
+            complete -
+            complete_and_continue {
+                # Should not actually occur as sspi.c no longer returns
+                # these codes
+                error "State $State handling not implemented."
+            }
+        }
+    }
+
+    # Recurse to return next state.
+    # This has to be OUTSIDE the [dict with] above else it will not
+    # see the updated values
+    return [sspi_step $ctx]
+}
+
+# Return a server context
+proc twapi::sspi_server_context {cred clientdata args} {
+    _init_security_context_syms
+    variable _server_security_context_syms
+
+    parseargs args {
+        {datarep.arg network {native network}}
+        confidentiality.bool
+        connection.bool
+        delegate.bool
+        extendederror.bool
+        identify.bool
+        integrity.bool
+        mutualauth.bool
+        replaydetect.bool
+        sequencedetect.bool
+        stream.bool
+    } -maxleftover 0 -nulldefault -setvars
+
+    set context_flags 0
+    foreach {opt flag} [array get _server_security_context_syms] {
+        if {[set $opt]} {
+            set context_flags [expr {$context_flags | $flag}]
+        }
+    }
+
+    set drep [kl_get {native 0x10 network 0} $datarep]
+    return [_construct_sspi_security_context \
+                sspiserver#[TwapiId] \
+                [AcceptSecurityContext \
+                     $cred \
+                     "" \
+                     [list [list 2 $clientdata]] \
+                     $context_flags \
+                     $drep] \
+                server \
+                $context_flags \
+                "" \
+                $cred \
+                $drep \
+               ]
+}
+
+
+# Get the security context flags after completion of request
+proc ::twapi::sspi_context_features {ctx} {
+    variable _sspi_state
+
+    set ctxh [_sspi_context_handle $ctx]
+
+    _init_security_context_syms
+
+    # We could directly look in the context itself but intead we make
+    # an explicit call, just in case they change after initial setup
+    set flags [QueryContextAttributes $ctxh 14]
+
+        # Mapping of symbols depends on whether it is a client or server
+        # context
+    if {[dict get $_sspi_state($ctx) Ctxtype] eq "client"} {
+        upvar 0 [namespace current]::_client_security_context_syms syms
+    } else {
+        upvar 0 [namespace current]::_server_security_context_syms syms
+    }
+
+    set result [list -raw $flags]
+    foreach {sym flag} [array get syms] {
+        lappend result -$sym [expr {($flag & $flags) != 0}]
+    }
+
+    return $result
+}
+
+# Get the user name for a security context
+proc twapi::sspi_context_username {ctx} {
+    return [QueryContextAttributes [_sspi_context_handle $ctx] 1]
+}
+
+# Get the field size information for a security context
+# TBD - update for SSL
+proc twapi::sspi_context_sizes {ctx} {
+    set sizes [QueryContextAttributes [_sspi_context_handle $ctx] 0]
+    return [twine {-maxtoken -maxsig -blocksize -trailersize} $sizes]
+}
+
+proc twapi::sspi_remote_cert {ctx} {
+    return [QueryContextAttributes [_sspi_context_handle $ctx] 0x53]
+}
+
+proc twapi::sspi_local_cert {ctx} {
+    return [QueryContextAttributes [_sspi_context_handle $ctx] 0x54]
+}
+
+proc twapi::sspi_issuers_accepted_by_peer {ctx} {
+    return [QueryContextAttributes [_sspi_context_handle $ctx] 0x59]
+}
+
+# Returns a signature
+proc twapi::sspi_sign {ctx data args} {
+    parseargs args {
+        {seqnum.int 0}
+        {qop.int 0}
+    } -maxleftover 0 -setvars
+
+    return [MakeSignature \
+                [_sspi_context_handle $ctx] \
+                $qop \
+                $data \
+                $seqnum]
+}
+
+# Verify signature
+proc twapi::sspi_verify_signature {ctx sig data args} {
+    parseargs args {
+        {seqnum.int 0}
+    } -maxleftover 0 -setvars
+
+    # Buffer type 2 - Token, 1- Data
+    return [VerifySignature \
+                [_sspi_context_handle $ctx] \
+                [list [list 2 $sig] [list 1 $data]] \
+                $seqnum]
+}
+
+# Encrypts a data as per a context
+# Returns {securitytrailer encrypteddata padding}
+proc twapi::sspi_encrypt {ctx data args} {
+    parseargs args {
+        {seqnum.int 0}
+        {qop.int 0}
+    } -maxleftover 0 -setvars
+
+    return [EncryptMessage \
+                [_sspi_context_handle $ctx] \
+                $qop \
+                $data \
+                $seqnum]
+}
+
+proc twapi::sspi_encrypt_stream {ctx data args} {
+    variable _sspi_state
+    
+    set h [_sspi_context_handle $ctx]
+
+    # TBD - docment options
+    parseargs args {
+        {qop.int 0}
+    } -maxleftover 0 -setvars
+
+    set enc ""
+    while {[string length $data]} {
+        lassign [EncryptStream $h $qop $data] fragment data
+        lappend enc $fragment
+    }
+
+    return [join $enc ""]
+}
+
+# chan must be in binary mode
+proc twapi::sspi_encrypt_and_write {ctx data chan args} {
+    variable _sspi_state
+    
+    set h [_sspi_context_handle $ctx]
+
+    parseargs args {
+        {qop.int 0}
+        {flush.bool 1}
+    } -maxleftover 0 -setvars
+
+    while {[string length $data]} {
+        lassign [EncryptStream $h $qop $data] fragment data
+        puts -nonewline $chan $fragment
+    }
+
+    if {$flush} {
+        chan flush $chan
+    }
+}
+
+
+# Decrypts a message
+# TBD - why does this not return a status like sspi_decrypt_stream ?
+proc twapi::sspi_decrypt {ctx sig data padding args} {
+    variable _sspi_state
+    _sspi_validate_handle $ctx
+
+    parseargs args {
+        {seqnum.int 0}
+    } -maxleftover 0 -setvars
+
+    # Buffer type 2 - Token, 1- Data, 9 - padding
+    set decrypted [DecryptMessage \
+                       [dict get $_sspi_state($ctx) Handle] \
+                       [list [list 2 $sig] [list 1 $data] [list 9 $padding]] \
+                       $seqnum]
+    set plaintext {}
+    # Pick out only the data buffers, ignoring pad buffers and signature
+    # Optimize copies by keeping as a list so in the common case of a 
+    # single buffer can return it as is. Multiple buffers are expensive
+    # because Tcl will shimmer each byte array into a list and then
+    # incur additional copies during joining
+    foreach buf $decrypted {
+        # SECBUFFER_DATA -> 1
+        if {[lindex $buf 0] == 1} {
+            lappend plaintext [lindex $buf 1]
+        }
+    }
+
+    if {[llength $plaintext] < 2} {
+        return [lindex $plaintext 0]
+    } else {
+        return [join $plaintext ""]
+    }
+}
+
+# Decrypts a stream
+proc twapi::sspi_decrypt_stream {ctx data} {
+    variable _sspi_state
+    set hctx [_sspi_context_handle $ctx]
+
+    # SSL decryption is done in max size chunks.
+    # We will loop collecting as much data as possible. Collecting
+    # as a list and joining at end minimizes internal byte copies
+    set plaintext {}
+    lassign [DecryptStream $hctx [dict get $_sspi_state($ctx) Input] $data] status decrypted extra
+    lappend plaintext $decrypted
+    
+    # TBD - handle renegotiate status
+    while {$status eq "ok" && [string length $extra]} {
+        # See if additional data and loop again
+        lassign [DecryptStream $hctx $extra] status decrypted extra
+        lappend plaintext $decrypted
+    }
+
+    dict set _sspi_state($ctx) Input $extra
+    if {$status eq "incomplete_message"} {
+        set status ok
+    }
+    return [list $status [join $plaintext ""]]
+}
+
+
+################################################################
+# Utility procs
+
+
+# Construct a high level SSPI security context structure
+# rawctx is context as returned from C level code
+proc twapi::_construct_sspi_security_context {id rawctx ctxtype inattr target credentials datarep} {
+    variable _sspi_state
+    
+    set _sspi_state($id) [dict merge [dict create Ctxtype $ctxtype \
+                                          Inattr $inattr \
+                                          Target $target \
+                                          Datarep $datarep \
+                                          Credentials $credentials] \
+                              [twine \
+                                   {State Handle Output Outattr Expiration Input} \
+                                   $rawctx]]
+
+    return $id
+}
+
+proc twapi::_sspi_validate_handle {ctx} {
+    variable _sspi_state
+
+    if {![info exists _sspi_state($ctx)]} {
+        badargs! "Invalid SSPI security context handle $ctx" 3
+    }
+}
+
+proc twapi::_sspi_context_handle {ctx} {
+    variable _sspi_state
+
+    if {![info exists _sspi_state($ctx)]} {
+        badargs! "Invalid SSPI security context handle $ctx" 3
+    }
+
+    return [dict get $_sspi_state($ctx) Handle]
+}
+
+proc twapi::_gather_secbuf_data {bufs} {
+    if {[llength $bufs] == 1} {
+        return [lindex [lindex $bufs 0] 1]
+    } else {
+        set data {}
+        foreach buf $bufs {
+            # First element is buffer type, which we do not care
+            # Second element is actual data
+            lappend data [lindex $buf 1]
+        }
+        return [join $data {}]
+    }
+}
+
+if {0} {
+    TBD - delete
+    set cred [sspi_acquire_credentials -package ssl -role client]
+    set client [sspi_client_context $cred -stream 1 -manualvalidation 1]
+    set out [sspi_step $client]
+    set so [socket 192.168.1.127 443]
+    fconfigure $so -blocking 0 -buffering none -translation binary
+    puts -nonewline $so [lindex $out 1]
+    
+    set data [read $so]
+    set out [sspi_step $client $data]
+    puts -nonewline $so [lindex $out 1]
+
+    set data [read $so]
+    set out [sspi_step $client $data]
+    
+    set out [sspi_encrypt_stream $client "GET / HTTP/1.0\r\n\r\n"]
+    puts -nonewline $so $out
+    set data [read $so]
+    set d [sspi_decrypt_stream $client $data]
+    sspi_shutdown_context $client
+    close $so ; sspi_free_credentials $cred ; sspi_free_context $client
+    sspi_context_free $client
+    sspi_shutdown_context $client
+
+    # INTERNAL client-server
+    proc 'sslsetup {} {
+        uplevel #0 {
+            twapi
+            source ../tests/testutil.tcl
+            set ca [make_test_certs]
+            set cacert [cert_store_find_certificate $ca subject_substring twapitestca]
+            set scert [cert_store_find_certificate $ca subject_substring twapitestserver]
+            set scred [sspi_acquire_credentials -package ssl -role server -credentials [sspi_schannel_credentials -certificates [list $scert]]]
+            set ccert [cert_store_find_certificate $ca subject_substring twapitestclient]
+            set ccred [sspi_acquire_credentials -package ssl -role client -credentials [sspi_schannel_credentials]]
+            set cctx [sspi_client_context $ccred -stream 1 -manualvalidation 1]
+            set cstep [sspi_step $cctx]
+
+            set sctx [sspi_server_context $scred [lindex $cstep 1] -stream 1]
+            set sstep [sspi_step $sctx]
+            set cstep [sspi_step $cctx [lindex $sstep 1]]
+            set sstep [sspi_step $sctx [lindex $cstep 1]]
+            set cstep [sspi_step $cctx [lindex $sstep 1]]
+        }
+    }
+    set out [sspi_encrypt_stream $cctx "This is a test"]
+
+    sspi_decrypt_stream $sctx $out
+    sspi_decrypt_stream $sctx ""
+    set out [sspi_encrypt_stream $sctx "This is a testx"]
+    sspi_decrypt_stream $cctx $out
+
+    proc 'ccred {} {
+        set store [cert_system_store_open twapitest user]
+        set ccert [cert_store_find_certificate $store subject_substring twapitestclient]
+        set ccred [sspi_acquire_credentials -package ssl -role client -credentials [sspi_schannel_credentials -certificates [list $ccert]]]
+        cert_store_release $store
+        cert_release $ccert
+        return $ccred
+    }
+
+}

src/punk86.vfs/lib/twapi4.7.2/storage.tcl

@@ -0,0 +1,616 @@
+#
+# Copyright (c) 2003, 2008 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# TBD - convert file spec to drive root path
+
+# Get info associated with a drive
+proc twapi::get_volume_info {drive args} {
+
+    set drive [_drive_rootpath $drive]
+
+    array set opts [parseargs args {
+        all size freespace used useravail type serialnum label maxcomponentlen fstype attr device extents
+    } -maxleftover 0]
+
+    if {$opts(all)} {
+        # -all option does not cover -type, -extents and -device
+        foreach opt {
+            all size freespace used useravail serialnum label maxcomponentlen fstype attr
+        } {
+            set opts($opt) 1
+        }
+    }
+
+    set result [list ]
+    if {$opts(size) || $opts(freespace) || $opts(used) || $opts(useravail)} {
+        lassign  [GetDiskFreeSpaceEx $drive] useravail size freespace
+        foreach opt {size freespace useravail}  {
+            if {$opts($opt)} {
+                lappend result -$opt [set $opt]
+            }
+        }
+        if {$opts(used)} {
+            lappend result -used [expr {$size - $freespace}]
+        }
+    }
+
+    if {$opts(type)} {
+        set drive_type [get_drive_type $drive]
+        lappend result -type $drive_type
+    }
+    if {$opts(device)} {
+        if {[_is_unc $drive]} {
+            # UNC paths cannot be used with QueryDosDevice
+            lappend result -device ""
+        } else {
+            lappend result -device [QueryDosDevice [string range $drive 0 1]]
+        }
+    }
+
+    if {$opts(extents)} {
+        set extents {}
+        if {! [_is_unc $drive]} {
+            trap {
+                set device_handle [create_file "\\\\.\\[string range $drive 0 1]" -createdisposition open_existing]
+                set bin [device_ioctl $device_handle 0x560000 -outputcount 32]
+                if {[binary scan $bin i nextents] != 1} {
+                    error "Truncated information returned from ioctl 0x560000"
+                }
+                set off 8
+                for {set i 0} {$i < $nextents} {incr i} {
+                    if {[binary scan $bin "@$off i x4 w w" extent(-disknumber) extent(-startingoffset) extent(-extentlength)] != 3} {
+                        error "Truncated information returned from ioctl 0x560000"
+                    }
+                    lappend extents [array get extent]
+                    incr off 24; # Size of one extent element
+                }
+            } onerror {} {
+                # Do nothing, device does not support extents or access denied
+                # Empty list is returned
+            } finally {
+                if {[info exists device_handle]} {
+                    CloseHandle $device_handle
+                }
+            }
+        }
+
+        lappend result -extents $extents
+    }
+
+    if {$opts(serialnum) || $opts(label) || $opts(maxcomponentlen)
+        || $opts(fstype) || $opts(attr)} {
+        foreach {label serialnum maxcomponentlen attr fstype} \
+            [GetVolumeInformation $drive] { break }
+        foreach opt {label maxcomponentlen fstype}  {
+            if {$opts($opt)} {
+                lappend result -$opt [set $opt]
+            }
+        }
+        if {$opts(serialnum)} {
+            set low [expr {$serialnum & 0x0000ffff}]
+            set high [expr {($serialnum >> 16) & 0x0000ffff}]
+            lappend result -serialnum [format "%.4X-%.4X" $high $low]
+        }
+        if {$opts(attr)} {
+            set attrs [list ]
+            foreach {sym val} {
+                case_preserved_names 2
+                unicode_on_disk 4
+                persistent_acls 8
+                file_compression 16
+                volume_quotas 32
+                supports_sparse_files 64
+                supports_reparse_points 128
+                supports_remote_storage 256
+                volume_is_compressed 0x8000
+                supports_object_ids 0x10000
+                supports_encryption 0x20000
+                named_streams 0x40000
+                read_only_volume 0x80000
+                sequential_write_once          0x00100000  
+                supports_transactions          0x00200000  
+                supports_hard_links            0x00400000  
+                supports_extended_attributes   0x00800000  
+                supports_open_by_file_id       0x01000000  
+                supports_usn_journal           0x02000000  
+            } {
+                if {$attr & $val} {
+                    lappend attrs $sym
+                }
+            }
+            lappend result -attr $attrs
+        }
+    }
+
+    return $result
+}
+interp alias {} twapi::get_drive_info {} twapi::get_volume_info
+
+
+# Check if disk has at least n bytes available for the user (NOT total free)
+proc twapi::user_drive_space_available {drv space} {
+    return [expr {$space <= [lindex [get_drive_info $drv -useravail] 1]}]
+}
+
+# Get the drive type
+proc twapi::get_drive_type {drive} {
+    # set type [GetDriveType "[string trimright $drive :/\\]:\\"]
+    set type [GetDriveType [_drive_rootpath $drive]]
+    switch -exact -- $type {
+        0 { return unknown}
+        1 { return invalid}
+        2 { return removable}
+        3 { return fixed}
+        4 { return remote}
+        5 { return cdrom}
+        6 { return ramdisk}
+    }
+}
+
+# Get list of drives
+proc twapi::find_logical_drives {args} {
+    array set opts [parseargs args {type.arg}]
+
+    set drives [list ]
+    foreach drive [_drivemask_to_drivelist [GetLogicalDrives]] {
+        if {(![info exists opts(type)]) ||
+            [lsearch -exact $opts(type) [get_drive_type $drive]] >= 0} {
+            lappend drives $drive
+        }
+    }
+    return $drives
+}
+
+twapi::proc* twapi::drive_ready {drive} {
+    uplevel #0 package require twapi_device
+} {
+    set drive [string trimright $drive "/\\"]
+    if {[string length $drive] != 2 || [string index $drive 1] ne ":"} {
+        error "Invalid drive specification"
+    }
+    set drive "\\\\.\\$drive"
+
+    # Do our best to avoid the Windows "Drive not ready" dialog
+    # 1 -> SEM_FAILCRITICALERRORS
+    if {[min_os_version 6]} {
+        set old_mode [SetErrorMode 1]
+    }
+    trap {
+
+        # We will first try using IOCTL_STORAGE_CHECK_VERIFY2 as that is
+        # much faster and only needs FILE_READ_ATTRIBUTES access.
+        set error [catch {
+            set h [create_file $drive -access file_read_attributes \
+                   -createdisposition open_existing -share {read write}]
+            device_ioctl $h 0x2d0800; # IOCTL_STORAGE_CHECK_VERIFY2
+        }]
+        if {[info exists h]} {
+            close_handle $h
+        }
+        if {! $error} {
+            return 1;               # Device is ready
+        }
+
+        # On error, try the older slower method. Note we now need
+        # GENERIC_READ access. (NOTE: FILE_READ_DATA will not work with some
+        # volume types)
+        unset -nocomplain h
+        set error [catch {
+            set h [create_file $drive -access generic_read \
+                       -createdisposition open_existing -share {read write}]
+            device_ioctl $h 0x2d4800; # IOCTL_STORAGE_CHECK_VERIFY
+        }]
+        if {[info exists h]} {
+            close_handle $h
+        }
+        if {! $error} {
+            return 1;           # Device is ready
+        }
+
+        # Remote shares sometimes return access denied with the above
+        # even when actually available. Try with good old file exists
+        # on root directory
+        return [file exists "[string range $drive end-1 end]\\"]
+    } finally {
+        if {[min_os_version 6]} {
+            SetErrorMode $old_mode
+        }
+    }
+}
+
+
+# Set the drive label
+proc twapi::set_drive_label {drive label} {
+    SetVolumeLabel [_drive_rootpath $drive] $label
+}
+
+# Maps a drive letter to the given path
+proc twapi::map_drive_local {drive path args} {
+    array set opts [parseargs args {raw}]
+
+    set drive [string range [_drive_rootpath $drive] 0 1]
+    DefineDosDevice $opts(raw) $drive [file nativename $path]
+}
+
+
+# Unmaps a drive letter
+proc twapi::unmap_drive_local {drive args} {
+    array set opts [parseargs args {
+        path.arg
+        raw
+    } -nulldefault]
+
+    set drive [string range [_drive_rootpath $drive] 0 1]
+
+    set flags $opts(raw)
+    setbits flags 0x2;                  # DDD_REMOVE_DEFINITION
+    if {$opts(path) ne ""} {
+        setbits flags 0x4;              # DDD_EXACT_MATCH_ON_REMOVE
+    }
+    DefineDosDevice $flags $drive [file nativename $opts(path)]
+}
+
+
+# Callback from C code
+proc twapi::_filesystem_monitor_handler {id changes} {
+    variable _filesystem_monitor_scripts
+    if {[info exists _filesystem_monitor_scripts($id)]} {
+        return [uplevel #0 [linsert $_filesystem_monitor_scripts($id) end $id $changes]]
+    } else {
+        # Callback queued after close. Ignore
+    }
+}
+
+# Monitor file changes
+proc twapi::begin_filesystem_monitor {path script args} {
+    variable _filesystem_monitor_scripts
+
+    array set opts [parseargs args {
+        {subtree.bool  0}
+        {filename.bool 0 0x1}
+        {dirname.bool  0 0x2}
+        {attr.bool     0 0x4}
+        {size.bool     0 0x8}
+        {write.bool    0 0x10}
+        {access.bool   0 0x20}
+        {create.bool   0 0x40}
+        {secd.bool     0 0x100}
+        {pattern.arg ""}
+        {patterns.arg ""}
+    } -maxleftover 0]
+
+    if {[string length $opts(pattern)] &&
+        [llength $opts(patterns)]} {
+        error "Options -pattern and -patterns are mutually exclusive. Note option -pattern is deprecated."
+    }
+
+    if {[string length $opts(pattern)]} {
+        # Old style single pattern. Convert to new -patterns
+        set opts(patterns) [list "+$opts(pattern)"]
+    }
+
+    # Change to use \ style path separator as that is what the file monitoring functions return
+    if {[llength $opts(patterns)]} {
+        foreach pat $opts(patterns) {
+            # Note / is replaced by \\ within the pattern
+            # since \ needs to be escaped with another \ within
+            # string match patterns
+            lappend pats [string map [list / \\\\] $pat]
+        }
+        set opts(patterns) $pats
+    }
+
+    set flags [expr { $opts(filename) | $opts(dirname) | $opts(attr) |
+                      $opts(size) | $opts(write) | $opts(access) |
+                      $opts(create) | $opts(secd)}]
+
+    if {! $flags} {
+        # If no options specified, default to all
+        set flags 0x17f
+    }
+
+    set id [Twapi_RegisterDirectoryMonitor $path $opts(subtree) $flags $opts(patterns)]
+    set _filesystem_monitor_scripts($id) $script
+    return $id
+}
+
+# Stop monitoring of files
+proc twapi::cancel_filesystem_monitor {id} {
+    variable _filesystem_monitor_scripts
+    if {[info exists _filesystem_monitor_scripts($id)]} {
+        Twapi_UnregisterDirectoryMonitor $id
+        unset _filesystem_monitor_scripts($id)
+    }
+}
+
+
+# Get list of volumes
+proc twapi::find_volumes {} {
+    set vols [list ]
+    set found 1
+    # Assumes there has to be at least one volume
+    lassign [FindFirstVolume] handle vol
+    while {$found} {
+        lappend vols $vol
+        lassign [FindNextVolume $handle] found vol
+    }
+    FindVolumeClose $handle
+    return $vols
+}
+
+# Get list of volume mount points
+proc twapi::find_volume_mount_points {vol} {
+    set mntpts [list ]
+    set found 1
+    trap {
+        lassign  [FindFirstVolumeMountPoint $vol] handle mntpt
+    } onerror {TWAPI_WIN32 18} {
+        # ERROR_NO_MORE_FILES
+        # No volume mount points
+        return [list ]
+    } onerror {TWAPI_WIN32 3} {
+        # Volume does not support them
+        return [list ]
+    }
+
+    # At least one volume found
+    while {$found} {
+        lappend mntpts $mntpt
+        lassign  [FindNextVolumeMountPoint $handle] found mntpt
+    }
+    FindVolumeMountPointClose $handle
+    return $mntpts
+}
+
+# Set volume mount point
+proc twapi::mount_volume {volpt volname} {
+    # Note we don't use _drive_rootpath for trimming since may not be root path
+    SetVolumeMountPoint "[string trimright $volpt /\\]\\" "[string trimright $volname /\\]\\"
+}
+
+# Delete volume mount point
+proc twapi::unmount_volume {volpt} {
+    # Note we don't use _drive_rootpath for trimming since may not be root path
+    DeleteVolumeMountPoint "[string trimright $volpt /\\]\\"
+}
+
+# Get the volume mounted at a volume mount point
+proc twapi::get_mounted_volume_name {volpt} {
+    # Note we don't use _drive_rootpath for trimming since may not be root path
+    return [GetVolumeNameForVolumeMountPoint "[string trimright $volpt /\\]\\"]
+}
+
+# Get the mount point corresponding to a given path
+proc twapi::get_volume_mount_point_for_path {path} {
+    return [GetVolumePathName [file nativename $path]]
+}
+
+
+# Return the times associated with a file
+proc twapi::get_file_times {fd args} {
+    array set opts [parseargs args {
+        all
+        mtime
+        ctime
+        atime
+    } -maxleftover 0]
+
+    # Figure out if fd is a file path, Tcl channel or a handle
+    set close_handle false
+    if {[file exists $fd]} {
+        # It's a file name
+        # 0x02000000 -> FILE_FLAG_BACKUP_SEMANTICS, always required in case 
+        # opening a directory (even if SeBackupPrivilege is not held
+        set h [create_file $fd -createdisposition open_existing -flags 0x02000000]
+        set close_handle true
+    } elseif {[catch {fconfigure $fd}]} {
+        # Not a Tcl channel, See if handle
+        if {[pointer? $fd]} {
+            set h $fd
+        } else {
+            error "$fd is not an existing file, handle or Tcl channel."
+        }
+    } else {
+        # Tcl channel
+        set h [get_tcl_channel_handle $fd read]
+    }
+
+    set result [list ]
+
+    foreach opt {ctime atime mtime} time [GetFileTime $h] {
+        if {$opts(all) || $opts($opt)} {
+            lappend result -$opt $time
+        }
+    }
+
+    if {$close_handle} {
+        CloseHandle $h
+    }
+
+    return $result
+}
+
+
+# Set the times associated with a file
+proc twapi::set_file_times {fd args} {
+
+    array set opts [parseargs args {
+        mtime.arg
+        ctime.arg
+        atime.arg
+        preserveatime
+    } -maxleftover 0 -nulldefault]
+
+    if {$opts(atime) ne "" && $opts(preserveatime)} {
+        win32_error 87 "Cannot specify -atime and -preserveatime at the same time."
+    }
+    if {$opts(preserveatime)} {
+        set opts(atime) -1;             # Meaning preserve access to original
+    }
+
+    # Figure out if fd is a file path, Tcl channel or a handle
+    set close_handle false
+    if {[file exists $fd]} {
+        if {$opts(preserveatime)} {
+            win32_error 87 "Cannot specify -preserveatime unless file is specified as a Tcl channel or a Win32 handle."
+        }
+
+        # It's a file name
+        # 0x02000000 -> FILE_FLAG_BACKUP_SEMANTICS, always required in case 
+        # opening a directory (even if SeBackupPrivilege is not held
+        set h [create_file $fd -access {generic_write} -createdisposition open_existing -flags 0x02000000]
+        set close_handle true
+    } elseif {[catch {fconfigure $fd}]} {
+        # Not a Tcl channel, assume a handle
+        set h $fd
+    } else {
+        # Tcl channel
+        set h [get_tcl_channel_handle $fd read]
+    }
+
+    SetFileTime $h $opts(ctime) $opts(atime) $opts(mtime)
+
+    if {$close_handle} {
+        CloseHandle $h
+    }
+
+    return
+}
+
+# Convert a device based path to a normalized Win32 path with drive letters
+proc twapi::normalize_device_rooted_path {path args} {
+    # TBD - keep a cache ?
+    # For example, we need to map \Device\HarddiskVolume1 to C:
+    # Can only do that by enumerating logical drives
+    set npath [file nativename $path]
+    if {![string match -nocase {\\Device\\*} $npath]} {
+        error "$path is not a valid device based path."
+    }
+    array set device_map {}
+    foreach drive [find_logical_drives] {
+        set device_path [lindex [lindex [get_volume_info $drive -device] 1] 0]
+        if {$device_path ne ""} {
+            set len [string length $device_path]
+            if {[string equal -nocase -length $len $path $device_path]} {
+                # Prefix matches, must be terminated by end or path separator
+                set ch [string index $npath $len]
+                if {$ch eq "" || $ch eq "\\"} {
+                    set path ${drive}[string range $npath $len end]
+                    if {[llength $args]} {
+                        upvar [lindex $args 0] retvar
+                        set retvar $path
+                        return 1
+                    } else {
+                        return $path
+                    }
+                }
+            }
+        }
+    }
+
+    if {[llength $args]} {
+        return 0
+    } else {
+        error "Could not map device based path '$path'"
+    }
+}
+
+proc twapi::flush_channel {chan} {
+    flush $chan
+    FlushFileBuffers [get_tcl_channel_handle $chan write]
+}
+
+proc twapi::find_file_open {path args} {
+    variable _find_tokens
+    variable _find_counter
+    parseargs args {
+        {detail.arg basic {basic full}}
+    } -setvars -maxleftover 0
+
+    set detail_level [expr {$detail eq "basic" ? 1 : 0}]
+    if {[min_os_version 6 1]} {
+        set flags 2;            # FIND_FIRST_EX_LARGE_FETCH - Win 7
+    } else {
+        set flags 0
+    }
+    # 0 -> search op. Could be specified as 1 to limit search to
+    # directories but that is only advisory and does not seem to work
+    # in many cases. So don't bother making it an option.
+    lassign [FindFirstFileEx $path $detail_level 0 "" $flags] handle entry
+    set token ff#[incr _find_counter]
+    set _find_tokens($token) [list Handle $handle Entry $entry]
+    return $token
+}
+
+proc twapi::find_file_close {token} {
+    variable _find_tokens
+    if {[info exists _find_tokens($token)]} {
+        FindClose [dict get $_find_tokens($token) Handle]
+        unset _find_tokens($token)
+    }
+    return
+}
+
+proc twapi::decode_file_attributes {attrs} {
+    return [_make_symbolic_bitmask $attrs {
+        archive               0x20
+        compressed            0x800
+        device                0x40
+        directory             0x10
+        encrypted             0x4000
+        hidden                0x2
+        integrity_stream      0x8000
+        normal                0x80
+        not_content_indexed   0x2000
+        no_scrub_data         0x20000
+        offline               0x1000
+        readonly              0x1
+        recall_on_data_access 0x400000
+        recall_on_open        0x40000
+        reparse_point         0x400
+        sparse_file           0x200
+        system                0x4
+        temporary             0x100
+        virtual               0x10000
+    }]
+}
+
+proc twapi::find_file_next {token varname} {
+    variable _find_tokens
+    if {![info exists _find_tokens($token)]} {
+        return false
+    }
+    if {[dict exists $_find_tokens($token) Entry]} {
+        set entry [dict get $_find_tokens($token) Entry]
+        dict unset _find_tokens($token) Entry
+    } else {
+        set entry [FindNextFile [dict get $_find_tokens($token) Handle]]
+    }
+    if {[llength $entry]} {
+        upvar 1 $varname result
+        set result [twine {attrs ctime atime mtime size reserve0 reserve1 name altname} $entry]
+        return true
+    } else {
+        return false
+    }
+}
+
+# Utility functions
+
+proc twapi::_drive_rootpath {drive} {
+    if {[_is_unc $drive]} {
+        # UNC
+        return "[string trimright $drive ]\\"
+    } else {
+        return "[string trimright $drive :/\\]:\\"
+    }
+}
+
+proc twapi::_is_unc {path} {
+    return [expr {[string match {\\\\*} $path] || [string match //* $path]}]
+}
+
+

src/punk86.vfs/lib/twapi4.7.2/synch.tcl

@@ -0,0 +1,94 @@
+#
+# Copyright (c) 2004, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+#
+# TBD - tcl wrappers for semaphores
+
+namespace eval twapi {
+}
+
+#
+# Create and return a handle to a mutex
+proc twapi::create_mutex {args} {
+    array set opts [parseargs args {
+        name.arg
+        secd.arg
+        inherit.bool
+        lock.bool
+    } -nulldefault -maxleftover 0]
+
+    if {$opts(name) ne "" && $opts(lock)} {
+        # TBD - remove this mutex limitation
+        # This is not a Win32 limitation but ours. Would need to change the C
+        # implementation and our return format
+        error "Option -lock must not be specified as true if mutex is named"
+    }
+
+    return [CreateMutex [_make_secattr $opts(secd) $opts(inherit)] $opts(lock) $opts(name)]
+}
+
+# Get handle to an existing mutex
+proc twapi::open_mutex {name args} {
+    array set opts [parseargs args {
+        {inherit.bool 0}
+        {access.arg {mutex_all_access}}
+    } -maxleftover 0]
+    
+    return [OpenMutex [_access_rights_to_mask $opts(access)] $opts(inherit) $name]
+}
+
+# Lock the mutex
+proc twapi::lock_mutex {h args} {
+    array set opts [parseargs args {
+        {wait.int -1}
+    }]
+
+    return [wait_on_handle $h -wait $opts(wait)]
+}
+
+
+# Unlock the mutex
+proc twapi::unlock_mutex {h} {
+    ReleaseMutex $h
+}
+
+#
+# Create and return a handle to a event
+proc twapi::create_event {args} {
+    array set opts [parseargs args {
+        name.arg
+        secd.arg
+        inherit.bool
+        signalled.bool
+        manualreset.bool
+        existvar.arg
+    } -nulldefault -maxleftover 0]
+
+    if {$opts(name) ne "" && $opts(signalled)} {
+        # Not clear whether event will be signalled state if it already
+        # existed but was not signalled
+        error "Option -signalled must not be specified as true if event is named."
+    }
+
+    lassign [CreateEvent [_make_secattr $opts(secd) $opts(inherit)] $opts(manualreset) $opts(signalled) $opts(name)]  h preexisted
+    if {$opts(manualreset)} {
+        # We want to catch attempts to wait on manual reset handles
+        set h [cast_handle $h HANDLE_MANUALRESETEVENT]
+    }
+    if {$opts(existvar) ne ""} {
+        upvar 1 $opts(existvar) existvar
+        set existvar $preexisted
+    }
+
+    return $h
+}
+
+interp alias {} twapi::set_event {} twapi::SetEvent
+interp alias {} twapi::reset_event {} twapi::ResetEvent
+
+# Hack to work with the various build configuration.
+if {[info commands ::twapi::get_version] ne ""} {
+    package provide twapi_synch [::twapi::get_version -patchlevel]
+}

src/punk86.vfs/lib/twapi4.7.2/twapi.tcl

@@ -0,0 +1,858 @@
+#
+# Copyright (c) 2003-2018, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# General definitions and procs used by all TWAPI modules
+
+package require Tcl 8.5
+package require registry
+
+namespace eval twapi {
+    # Get rid of this ugliness  -  TBD
+    # Note this is different from NULL or {0 VOID} etc. It is more like
+    # a null token passed to functions that expect ptr to strings and
+    # allow the ptr to be NULL.
+    variable nullptr "__null__"
+
+    variable scriptdir [file dirname [info script]]
+
+    # Name of the var holding log messages in reflected in the C
+    # code, don't change it!
+    variable log_messages {}
+
+    ################################################################
+    # Following procs are used early in init process so defined here
+
+    # Throws a bad argument error that appears to come from caller's invocation
+    # (if default level is 2)
+    proc badargs! {msg {level 2}} {
+        return -level $level -code error -errorcode [list TWAPI BADARGS $msg] $msg
+    }
+
+    proc lambda {arglist body {ns {}}} {
+        return [list ::apply [list $arglist $body $ns]]
+    }
+
+    # Similar to lambda but takes additional parameters to be passed
+    # to the anonymous functin
+    proc lambda* {arglist body {ns {}} args} {
+        return [list ::apply [list $arglist $body $ns] {*}$args]
+    }
+
+    # Rethrow original exception from inside a trap
+    proc rethrow {} {
+        return -code error -level 0 -options [twapi::trapoptions] [twapi::trapresult]
+    }
+
+    # Dict lookup, returns default (from args) if not in dict and
+    # key itself if no defaults specified
+    proc dict* {d key args} {
+        if {[dict exists $d $key]} {
+            return [dict get $d $key]
+        } elseif {[llength $args]} {
+            return [lindex $args 0]
+        } else {
+            return $key
+        }
+    }
+
+    proc dict! {d key {frame 0}} {
+        if {[dict exists $d $key]} {
+            return [dict get $d $key]
+        } else {
+            # frame is how must above the caller errorInfo must appear
+            return [badargs! "Bad value \"$key\". Must be one of [join [dict keys $d] {, }]" [incr frame 2]]
+        }
+    }
+
+
+    # Defines a proc with some initialization code
+    proc proc* {procname arglist initcode body} {
+        if {![string match ::* $procname]} {
+            set ns [uplevel 1 {namespace current}]
+            set procname ${ns}::$procname
+        }
+        set proc_def [format {proc %s {%s} {%s ; proc %s {%s} {%s} ; uplevel 1 [list %s] [lrange [info level 0] 1 end]}} $procname $arglist $initcode $procname $arglist $body $procname]
+        uplevel 1 $proc_def
+    }
+
+    # Swap keys and values
+    proc swapl {l} {
+        set swapped {}
+        foreach {a b} $l {
+            lappend swapped $b $a
+        }
+        return $swapped
+    }
+
+    # TBD - see if C would make faster
+    # Returns a list consisting of n'th index within each sublist element
+    # Should we allow n to be a nested index ? C impl may be harder
+    proc lpick {l {n 0}} {
+        set result {}
+        foreach e $l {
+            lappend result [lindex $e $n]
+        }
+        return $result
+    }
+
+    # Simple helper to treat lists as a stack
+    proc lpop {vl} {
+        upvar 1 $vl l
+        set top [lindex $l end]
+        # K combinator trick to reset l to allow lreplace to work in place
+        set l [lreplace $l [set l end] end]
+        return $top
+    }
+
+    # twine list of n items
+    proc ntwine {fields l} {
+        set ntwine {}
+        foreach e $l {
+            lappend ntwine [twine $fields $e]
+        }
+        return $ntwine
+    }
+
+    # Qualifies a name in context of caller's caller
+    proc callerns {name} {
+        if {[string match "::*" $name]} {
+            return $name
+        }
+        if {[info level] > 2} {
+            return [uplevel 2 namespace current]::$name
+        } else {
+            return ::$name
+        }
+    }
+}
+
+# Make twapi versions the same as the base module versions
+set twapi::version(twapi) $::twapi::version(twapi_base)
+
+#
+# log for tracing / debug messages.
+proc twapi::debuglog_clear {} {
+    variable log_messages
+    set log_messages {}
+}
+
+proc twapi::debuglog_enable {} {
+    catch {rename [namespace current]::debuglog {}}
+    interp alias {} [namespace current]::debuglog {} [namespace current]::Twapi_AppendLog
+}
+
+proc twapi::debuglog_disable {} {
+    proc [namespace current]::debuglog {args} {}
+}
+
+proc twapi::debuglog_get {} {
+    variable log_messages
+    return $log_messages
+}
+
+# Logging disabled by default
+twapi::debuglog_disable
+
+proc twapi::get_build_config {{key ""}} {
+    variable build_ids
+    array set config [GetTwapiBuildInfo]
+
+    # This is actually a runtime config and might not have been initialized
+    if {[info exists ::twapi::use_tcloo_for_com]} {
+        if {$::twapi::use_tcloo_for_com} {
+            set config(comobj_ootype) tcloo
+        } else {
+            set config(comobj_ootype) metoo
+        }
+    } else {
+        set config(comobj_ootype) uninitialized
+    }
+
+    if {$key eq ""} {
+        return [array get config]
+    } else {
+        if {![info exists config($key)]} {
+            error "key not known"; # Matches tcl::pkgconfig error message
+        }
+        return $config($key)
+    }
+}
+
+# This matches the pkgconfig command as defined by Tcl_RegisterConfig
+# TBD - Doc and test
+proc twapi::pkgconfig {subcommand {arg {}}} {
+    if {$subcommand eq "list"} {
+        if {$arg ne ""} {
+            error {wrong # args: should be "twapi::pkgconfig list"}
+        }
+        return [dict keys [get_build_config]]
+    } elseif {$subcommand eq "get"} {
+        if {$arg eq ""} {
+            error {wrong # args: should be "twapi::pkgconfig get key"}
+        }
+        return [get_build_config $arg]
+    } else {
+        error {wrong # args: should be "tcl::pkgconfig subcommand ?arg?"}
+    }
+}
+
+# TBD - document
+proc twapi::support_report {} {
+    set report "Operating system: [get_os_description]\n"
+    append report "Processors: [get_processor_count]\n"
+    append report "WOW64: [wow64_process]\n"
+    append report "Virtualized: [virtualized_process]\n"
+    append report "System locale: [get_system_default_lcid], [get_system_default_langid]\n"
+    append report "User locale: [get_user_default_lcid], [get_user_default_langid]\n"
+    append report "Tcl version: [info patchlevel]\n"
+    append report "tcl_platform:\n"
+    foreach k [lsort -dictionary [array names ::tcl_platform]] {
+        append report "  $k = $::tcl_platform($k)\n"
+    }
+    append report "TWAPI version: [get_version -patchlevel]\n"
+    array set a [get_build_config]
+    append report "TWAPI config:\n"
+    foreach k [lsort -dictionary [array names a]] {
+        append report "  $k = $a($k)\n"
+    }
+    append report "\nDebug log:\n[join [debuglog_get] \n]\n"
+}
+
+
+# Returns a list of raw Windows API functions supported
+proc twapi::list_raw_api {} {
+    set rawapi [list ]
+    foreach fn [info commands ::twapi::*] {
+         if {[regexp {^::twapi::([A-Z][^_]*)$} $fn ignore fn]} {
+             lappend rawapi $fn
+         }
+    }
+    return $rawapi
+}
+
+
+# Wait for $wait_ms milliseconds or until $script returns $guard. $gap_ms is
+# time between retries to call $script
+# TBD - write a version that will allow other events to be processed
+proc twapi::wait {script guard wait_ms {gap_ms 10}} {
+    if {$gap_ms == 0} {
+        set gap_ms 10
+    }
+    set end_ms [expr {[clock clicks -milliseconds] + $wait_ms}]
+    while {[clock clicks -milliseconds] < $end_ms} {
+        set script_result [uplevel $script]
+        if {[string equal $script_result $guard]} {
+            return 1
+        }
+        after $gap_ms
+    }
+    # Reached limit, one last try
+    return [string equal [uplevel $script] $guard]
+}
+
+# Get twapi version
+proc twapi::get_version {args} {
+    variable version
+    array set opts [parseargs args {patchlevel}]
+    if {$opts(patchlevel)} {
+        return $version(twapi)
+    } else {
+        # Only return major, minor
+        set ver $version(twapi)
+        regexp {^([[:digit:]]+\.[[:digit:]]+)[.ab]} $version(twapi) - ver
+        return $ver
+    }
+}
+
+# Set all elements of the array to specified value
+proc twapi::_array_set_all {v_arr val} {
+    upvar $v_arr arr
+    foreach e [array names arr] {
+        set arr($e) $val
+    }
+}
+
+# Check if any of the specified array elements are non-0
+proc twapi::_array_non_zero_entry {v_arr indices} {
+    upvar $v_arr arr
+    foreach i $indices {
+        if {$arr($i)} {
+            return 1
+        }
+    }
+    return 0
+}
+
+# Check if any of the specified array elements are non-0
+# and return them as a list of options (preceded with -)
+proc twapi::_array_non_zero_switches {v_arr indices all} {
+    upvar $v_arr arr
+    set result [list ]
+    foreach i $indices {
+        if {$all || ([info exists arr($i)] && $arr($i))} {
+            lappend result -$i
+        }
+    }
+    return $result
+}
+
+
+# Bitmask operations on 32bit values
+# The int() casts are to deal with hex-decimal sign extension issues
+proc twapi::setbits {v_bits mask} {
+    upvar $v_bits bits
+    set bits [expr {int($bits) | int($mask)}]
+    return $bits
+}
+proc twapi::resetbits {v_bits mask} {
+    upvar $v_bits bits
+    set bits [expr {int($bits) & int(~ $mask)}]
+    return $bits
+}
+
+# Return a bitmask corresponding to a list of symbolic and integer values
+# If symvals is a single item, it is an array else a list of sym bitmask pairs
+proc twapi::_parse_symbolic_bitmask {syms symvals} {
+    if {[llength $symvals] == 1} {
+        upvar $symvals lookup
+    } else {
+        array set lookup $symvals
+    }
+    set bits 0
+    foreach sym $syms {
+        if {[info exists lookup($sym)]} {
+            set bits [expr {$bits | $lookup($sym)}]
+        } else {
+            set bits [expr {$bits | $sym}]
+        }
+    }
+    return $bits
+}
+
+# Return a list of symbols corresponding to a bitmask
+proc twapi::_make_symbolic_bitmask {bits symvals {append_unknown 1}} {
+    if {[llength $symvals] == 1} {
+        upvar $symvals lookup
+        set map [array get lookup]
+    } else {
+        set map $symvals
+    }
+    set symbits 0
+    set symmask [list ]
+    foreach {sym val} $map {
+        if {$bits & $val} {
+            set symbits [expr {$symbits | $val}]
+            lappend symmask $sym
+        }
+    }
+
+    # Get rid of bits that mapped to symbols
+    set bits [expr {$bits & ~$symbits}]
+    # If any left over, add them
+    if {$bits && $append_unknown} {
+        lappend symmask $bits
+    }
+    return $symmask
+}
+
+# Return a bitmask corresponding to a list of symbolic and integer values
+# If symvals is a single item, it is an array else a list of sym bitmask pairs
+# Ditto for switches - an array or flat list of switch boolean pairs
+proc twapi::_switches_to_bitmask {switches symvals {bits 0}} {
+    if {[llength $symvals] == 1} {
+        upvar $symvals lookup
+    } else {
+        array set lookup $symvals
+    }
+    if {[llength $switches] == 1} {
+        upvar $switches swtable
+    } else {
+        array set swtable $switches
+    }
+
+    foreach {switch bool} [array get swtable] {
+        if {$bool} {
+            set bits [expr {$bits | $lookup($switch)}]
+        } else {
+            set bits [expr {$bits & ~ $lookup($switch)}]
+        }
+    }
+    return $bits
+}
+
+# Return a list of switche bool pairs corresponding to a bitmask
+proc twapi::_bitmask_to_switches {bits symvals} {
+    if {[llength $symvals] == 1} {
+        upvar $symvals lookup
+        set map [array get lookup]
+    } else {
+        set map $symvals
+    }
+    set symbits 0
+    set symmask [list ]
+    foreach {sym val} $map {
+        if {$bits & $val} {
+            set symbits [expr {$symbits | $val}]
+            lappend symmask $sym 1
+        } else {
+            lappend symmask $sym 0
+        }
+    }
+
+    return $symmask
+}
+
+# Make and return a keyed list
+proc twapi::kl_create {args} {
+    if {[llength $args] & 1} {
+        error "No value specified for keyed list field [lindex $args end]. A keyed list must have an even number of elements."
+    }
+    return $args
+}
+
+# Make a keyed list given fields and values
+interp alias {} twapi::kl_create2 {} twapi::twine
+
+# Set a key value
+proc twapi::kl_set {kl field newval} {
+   set i 0
+   foreach {fld val} $kl {
+        if {[string equal $fld $field]} {
+            incr i
+            return [lreplace $kl $i $i $newval]
+        }
+        incr i 2
+    }
+    lappend kl $field $newval
+    return $kl
+}
+
+# Check if a field exists in the keyed list
+proc twapi::kl_vget {kl field varname} {
+    upvar $varname var
+    return [expr {! [catch {set var [kl_get $kl $field]}]}]
+}
+
+# Remote/unset a key value
+proc twapi::kl_unset {kl field} {
+    array set arr $kl
+    unset -nocomplain arr($field)
+    return [array get arr]
+}
+
+# Compare two keyed lists
+proc twapi::kl_equal {kl_a kl_b} {
+    array set a $kl_a
+    foreach {kb valb} $kl_b {
+        if {[info exists a($kb)] && ($a($kb) == $valb)} {
+            unset a($kb)
+        } else {
+            return 0
+        }
+    }
+    if {[array size a]} {
+        return 0
+    } else {
+        return 1
+    }
+}
+
+# Return the field names in a keyed list in the same order that they
+# occured
+proc twapi::kl_fields {kl} {
+    set fields [list ]
+    foreach {fld val} $kl {
+        lappend fields $fld
+    }
+    return $fields
+}
+
+# Returns a flat list of the $field fields from a list
+# of keyed lists
+proc twapi::kl_flatten {list_of_kl args} {
+    set result {}
+    foreach kl $list_of_kl {
+        foreach field $args {
+            lappend result [kl_get $kl $field]
+        }
+    }
+    return $result
+}
+
+
+# Return an array as a list of -index value pairs
+proc twapi::_get_array_as_options {v_arr} {
+    upvar $v_arr arr
+    set result [list ]
+    foreach {index value} [array get arr] {
+        lappend result -$index $value
+    }
+    return $result
+}
+
+# Parse a list of two integers or a x,y pair and return a list of two integers
+# Generate exception on format error using msg
+proc twapi::_parse_integer_pair {pair {msg "Invalid integer pair"}} {
+    if {[llength $pair] == 2} {
+        lassign $pair first second
+        if {[string is integer -strict $first] &&
+            [string is integer -strict $second]} {
+            return [list $first $second]
+        }
+    } elseif {[regexp {^([[:digit:]]+),([[:digit:]]+)$} $pair dummy first second]} {
+        return [list $first $second]
+    }
+
+    error "$msg: '$pair'. Should be a list of two integers or in the form 'x,y'"
+}
+
+
+# Convert file names by substituting \SystemRoot and \??\ sequences
+proc twapi::_normalize_path {path} {
+    # Get rid of \??\ prefixes
+    regsub {^[\\/]\?\?[\\/](.*)} $path {\1} path
+
+    # Replace leading \SystemRoot with real system root
+    if {[string match -nocase {[\\/]Systemroot*} $path] &&
+        ([string index $path 11] in [list "" / \\])} {
+        return [file join [twapi::GetSystemWindowsDirectory] [string range $path 12 end]]
+    } else {
+        return [file normalize $path]
+    }
+}
+
+
+# Convert seconds to a list {Year Month Day Hour Min Sec Ms}
+# (Ms will always be zero).
+proc twapi::_seconds_to_timelist {secs {gmt 0}} {
+    # For each field, we need to trim the leading zeroes
+    set result [list ]
+    foreach x [clock format $secs -format "%Y %m %e %k %M %S 0" -gmt $gmt] {
+        lappend result [scan $x %d]
+    }
+    return $result
+}
+
+# Convert local time list {Year Month Day Hour Min Sec Ms} to seconds
+# (Ms field is ignored)
+# TBD - fix this gmt issue - not clear whether caller expects gmt time
+proc twapi::_timelist_to_seconds {timelist} {
+    return [clock scan [_timelist_to_timestring $timelist] -gmt false]
+}
+
+# Convert local time list {Year Month Day Hour Min Sec Ms} to a time string
+# (Ms field is ignored)
+proc twapi::_timelist_to_timestring {timelist} {
+    if {[llength $timelist] < 6} {
+        error "Invalid time list format"
+    }
+
+    return "[lindex $timelist 0]-[lindex $timelist 1]-[lindex $timelist 2] [lindex $timelist 3]:[lindex $timelist 4]:[lindex $timelist 5]"
+}
+
+# Convert a time string to a time list
+proc twapi::_timestring_to_timelist {timestring} {
+    return [_seconds_to_timelist [clock scan $timestring -gmt false]]
+}
+
+# Parse raw memory like binary scan command
+proc twapi::mem_binary_scan {mem off mem_sz args} {
+    uplevel [list binary scan [Twapi_ReadMemory 1 $mem $off $mem_sz]] $args
+}
+
+
+# Validate guid syntax
+proc twapi::_validate_guid {guid} {
+    if {![Twapi_IsValidGUID $guid]} {
+        error "Invalid GUID syntax: '$guid'"
+    }
+}
+
+# Validate uuid syntax
+proc twapi::_validate_uuid {uuid} {
+    if {![regexp {^[[:xdigit:]]{8}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{12}$} $uuid]} {
+        error "Invalid UUID syntax: '$uuid'"
+    }
+}
+
+# Extract a UCS-16 string from a binary. Cannot directly use
+# encoding convertfrom because that will not stop at the terminating
+# null. The UCS-16 assumed to be little endian.
+proc twapi::_ucs16_binary_to_string {bin {off 0}} {
+    set bin [string range $bin $off end]
+
+    # Find the terminating null.
+    set off [string first \0\0 $bin]
+    while {$off > 0 && ($off & 1)} {
+        # Offset off is odd and so crosses a char boundary, so not the
+        # terminating null. Step to the char boundary and start search again
+        incr off
+        set off [string first \0\0 $bin $off]
+    }
+    # off is offset of terminating UCS-16 null, or -1 if not found
+    if {$off < 0} {
+        # No terminator
+        return [encoding convertfrom unicode $bin]
+    } else {
+        return [encoding convertfrom unicode [string range $bin 0 $off-1]]
+    }
+}
+
+# Extract a string from a binary. Cannot directly use
+# encoding convertfrom because that will not stop at the terminating
+# null.
+proc twapi::_ascii_binary_to_string {bin {off 0}} {
+    set bin [string range $bin $off end]
+
+    # Find the terminating null.
+    set off [string first \0 $bin]
+
+    # off is offset of terminating null, or -1 if not found
+    if {$off < 0} {
+        # No terminator
+        return [encoding convertfrom ascii $bin]
+    } else {
+        return [encoding convertfrom ascii [string range $bin 0 $off-1]]
+    }
+}
+
+
+# Given a binary, return a GUID. The formatting is done as per the
+# Windows StringFromGUID2 convention used by COM
+proc twapi::_binary_to_guid {bin {off 0}} {
+    if {[binary scan $bin "@$off i s s H4 H12" g1 g2 g3 g4 g5] != 5} {
+        error "Invalid GUID binary"
+    }
+
+    return [format "{%8.8X-%2.2hX-%2.2hX-%s}" $g1 $g2 $g3 [string toupper "$g4-$g5"]]
+}
+
+# Given a guid string, return a GUID in binary form
+proc twapi::_guid_to_binary {guid} {
+    _validate_guid $guid
+    lassign [split [string range $guid 1 end-1] -] g1 g2 g3 g4 g5
+    return [binary format "i s s H4 H12" 0x$g1 0x$g2 0x$g3 $g4 $g5]
+}
+
+# Return a guid from raw memory
+proc twapi::_decode_mem_guid {mem {off 0}} {
+    return [_binary_to_guid [Twapi_ReadMemory 1 $mem $off 16]]
+}
+
+# Convert a Windows registry value to Tcl form. mem is a raw
+# memory object. off is the offset into the memory object to read.
+# $type is a integer corresponding
+# to the registry types
+proc twapi::_decode_mem_registry_value {type mem len {off 0}} {
+    set type [expr {$type}];    # Convert hex etc. to decimal form
+    switch -exact -- $type {
+        1 -
+        2 {
+            return [list [expr {$type == 2 ? "expand_sz" : "sz"}] \
+                        [Twapi_ReadMemory 3 $mem $off $len 1]]
+        }
+        7 {
+            # Collect strings until we come across an empty string
+            # Note two nulls right at the start will result in
+            # an empty list. Should it result in a list with
+            # one empty string element? Most code on the web treats
+            # it as the former so we do too.
+           set multi [list ]
+            while {1} {
+                set str [Twapi_ReadMemory 3 $mem $off -1]
+                set n [string length $str]
+                # Check for out of bounds. Cannot check for this before
+                # actually reading the string since we do not know size
+                # of the string.
+                if {($len != -1) && ($off+$n+1) > $len} {
+                    error "Possible memory corruption: read memory beyond specified memory size."
+                }
+                if {$n == 0} {
+                    return [list multi_sz $multi]
+                }
+                lappend multi $str
+                # Move offset by length of the string and terminating null
+                # (times 2 since unicode and we want byte offset)
+                incr off [expr {2*($n+1)}]
+            }
+        }
+        4 {
+            if {$len < 4} {
+                error "Insufficient number of bytes to convert to integer."
+            }
+            return [list dword [Twapi_ReadMemory 0 $mem $off]]
+        }
+        5 {
+            if {$len < 4} {
+                error "Insufficient number of bytes to convert to big-endian integer."
+            }
+            set type "dword_big_endian"
+            set scanfmt "I"
+            set len 4
+        }
+        11 {
+            if {$len < 8} {
+                error "Insufficient number of bytes to convert to wide integer."
+            }
+            set type "qword"
+            set scanfmt "w"
+            set len 8
+        }
+        0 { set type "none" }
+        6 { set type "link" }
+        8 { set type "resource_list" }
+        3 { set type "binary" }
+        default {
+            error "Unsupported registry value type '$type'"
+        }
+    }
+
+    set val [Twapi_ReadMemory 1 $mem $off $len]
+    if {[info exists scanfmt]} {
+        if {[binary scan $val $scanfmt val] != 1} {
+            error "Could not convert from binary value using scan format $scanfmt"
+        }
+    }
+
+    return [list $type $val]
+}
+
+
+proc twapi::_log_timestamp {} {
+    return [clock format [clock seconds] -format "%a %T"]
+}
+
+
+# Helper for Net*Enum type functions taking a common set of arguments
+proc twapi::_net_enum_helper {function args} {
+    if {[llength $args] == 1} {
+        set args [lindex $args 0]
+    }
+
+    # -namelevel is used internally to indicate what level is to be used
+    # to retrieve names. -preargs and -postargs are used internally to
+    # add additional arguments at specific positions in the generic call.
+    array set opts [parseargs args {
+        {system.arg ""}
+        level.int
+        resume.int
+        filter.int
+        {namelevel.int 0}
+        {preargs.arg {}}
+        {postargs.arg {}}
+        {namefield.int 0}
+        fields.arg
+    } -maxleftover 0]
+
+    if {[info exists opts(level)]} {
+        set level $opts(level)
+        if {! [info exists opts(fields)]} {
+            badargs! "Option -fields must be specified if -level is specified"
+        }
+    } else {
+        set level $opts(namelevel)
+    }
+
+    # Note later we need to know if opts(resume) was specified so
+    # don't change this to just default -resume to 0 above
+    if {[info exists opts(resume)]} {
+        set resumehandle $opts(resume)
+    } else {
+        set resumehandle 0
+    }
+
+    set moredata 1
+    set result {}
+    while {$moredata} {
+        if {[info exists opts(filter)]} {
+            lassign  [$function $opts(system) {*}$opts(preargs) $level $opts(filter) {*}$opts(postargs) $resumehandle] moredata resumehandle totalentries entries
+        } else {
+            lassign [$function $opts(system) {*}$opts(preargs) $level {*}$opts(postargs) $resumehandle] moredata resumehandle totalentries entries
+        }
+        # If caller does not want all data in one lump stop here
+        if {[info exists opts(resume)]} {
+            if {[info exists opts(level)]} {
+                return [list $moredata $resumehandle $totalentries [list $opts(fields) $entries]]
+            } else {
+                # Return flat list of names
+                return [list $moredata $resumehandle $totalentries [lpick $entries $opts(namefield)]]
+            }
+        }
+
+        lappend result {*}$entries
+    }
+
+    # Return what we have. Format depend on caller options.
+    if {[info exists opts(level)]} {
+        return [list $opts(fields) $result]
+    } else {
+        return [lpick $result $opts(namefield)]
+    }
+}
+
+# If we are not being sourced from a executable resource, need to
+# source the remaining support files. In the former case, they are
+# automatically combined into one so the sourcing is not needed.
+if {![info exists twapi::twapi_base_rc_sourced]} {
+    apply {{filelist} {
+        set dir [file dirname [info script]]
+        foreach f $filelist {
+            uplevel #0 [list source [file join $dir $f]]
+        }
+    }} {base.tcl handle.tcl win.tcl adsi.tcl}
+}
+
+# Used in various matcher callbacks to signify always include etc.
+# TBD - document
+proc twapi::true {args} {
+    return true
+}
+
+
+namespace eval twapi {
+    # Get a handle to ourselves. This handle never need be closed
+    variable my_process_handle [GetCurrentProcess]
+}
+
+# Only used internally for test validation.
+# NOT the same as export_public_commands
+proc twapi::_get_public_commands {} {
+    variable exports;           # Populated via pkgIndex.tcl
+    if {[info exists exports]} {
+        return [concat {*}[dict values $exports]]
+    } else {
+        set cmds {}
+        foreach cmd [lsearch -regexp -inline -all [info commands [namespace current]::*] {::twapi::[a-z].*}] {
+            lappend cmds [namespace tail $cmd]
+        }
+        return $cmds
+    }
+}
+
+proc twapi::export_public_commands {} {
+    variable exports;           # Populated via pkgIndex.tcl
+    if {[info exists exports]} {
+        # Only export commands under twapi (e.g. not metoo)
+        dict for {ns cmds} $exports {
+            if {[regexp {^::twapi($|::)} $ns]} {
+                uplevel #0 [list namespace eval $ns [list namespace export {*}$cmds]
+] 
+            }
+        }
+    } else {
+        set cmds {}
+        foreach cmd [lsearch -regexp -inline -all [info commands [namespace current]::*] {::twapi::[a-z].*}] {
+            lappend cmds [namespace tail $cmd]
+        }
+        namespace eval [namespace current] "namespace export {*}$cmds"
+    }
+}
+
+proc twapi::import_commands {} {
+    export_public_commands
+    uplevel namespace import twapi::*
+}
+

src/punk86.vfs/lib/twapi4.7.2/twapi_entry.tcl

@@ -0,0 +1,11 @@
+# -*- tcl -*-
+namespace eval twapi {
+    variable version
+    set version(twapi)     4.7.2
+    variable patchlevel    4.7.2
+    variable package_name  twapi
+    variable dll_base_name twapi[string map {. {}} 4.7.2]
+    variable scriptdir     [file dirname [info script]]
+}
+
+source [file join $twapi::scriptdir twapi.tcl]

src/punk86.vfs/lib/twapi4.7.2/win.tcl

@@ -0,0 +1,131 @@
+#
+# Copyright (c) 2012 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# Contains common windowing and notification infrastructure
+
+namespace eval twapi {
+    variable null_hwin ""
+
+    # Windows messages that are directly accessible from script. These
+    # are handled by the default notifications window and passed to
+    # the twapi::_script_wm_handler. These messages must be in the
+    # range (1056 = 1024+32) - (1024+32+31) (see twapi_wm.h)
+    variable _wm_script_msgs
+    array set _wm_script_msgs {
+        TASKBAR_RESTART      1031
+        NOTIFY_ICON_CALLBACK 1056
+    }
+    proc _get_script_wm {tok} {
+        variable _wm_script_msgs
+        return $_wm_script_msgs($tok)
+    }
+}
+
+# Backward compatibility aliases
+interp alias {} twapi::GetWindowLong {} twapi::GetWindowLongPtr
+interp alias {} twapi::SetWindowLong {} twapi::SetWindowLongPtr
+
+# Return the long value at the given index
+# This is a raw function, and should generally be used only to get
+# non-system defined indices
+proc twapi::get_window_long {hwin index} {
+    return [GetWindowLongPtr $hwin $index]
+}
+
+# Set the long value at the given index and return the previous value
+# This is a raw function, and should generally be used only to get
+# non-system defined indices
+proc twapi::set_window_long {hwin index val} {
+    set oldval [SetWindowLongPtr $hwin $index $val]
+}
+
+# Set the user data associated with a window. Returns the previous value
+proc twapi::set_window_userdata {hwin val} {
+    # GWL_USERDATA -> -21
+    return [SetWindowLongPtr $hwin -21 $val]
+}
+
+# Attaches to the thread queue of the thread owning $hwin and executes
+# script in the caller's scope
+proc twapi::_attach_hwin_and_eval {hwin script} {
+    set me [GetCurrentThreadId]
+    set hwin_tid [lindex [GetWindowThreadProcessId $hwin] 0]
+    if {$hwin_tid == 0} {
+        error "Window $hwin does not exist or could not get its thread owner"
+    }
+
+    # Cannot (and no need to) attach to oneself so just exec script directly
+    if {$me == $hwin_tid} {
+        return [uplevel 1 $script]
+    }
+
+    trap {
+        if {![AttachThreadInput $me $hwin_tid 1]} {
+            error "Could not attach to thread input for window $hwin"
+        }
+        set result [uplevel 1 $script]
+    } finally {
+        AttachThreadInput $me $hwin_tid 0
+    }
+
+    return $result
+}
+
+proc twapi::_register_script_wm_handler {msg cmdprefix {overwrite 0}} {
+    variable _wm_registrations
+
+    # Ensure notification window exists
+    twapi::Twapi_GetNotificationWindow
+
+    # The incr ensures decimal format
+    # The lrange ensure proper list format
+    if {$overwrite} {
+        set _wm_registrations([incr msg 0]) [list [lrange $cmdprefix 0 end]]
+    } else {
+        lappend _wm_registrations([incr msg 0]) [lrange $cmdprefix 0 end]
+    }
+}
+
+proc twapi::_unregister_script_wm_handler {msg cmdprefix} {
+    variable _wm_registrations
+
+    # The incr ensures decimal format
+    incr msg 0
+    # The lrange ensure proper list format
+    if {[info exists _wm_registrations($msg)]} {
+        set _wm_registrations($msg) [lsearch -exact -inline -not -all $_wm_registrations($msg) [lrange $cmdprefix 0 end]]
+    }                                 
+}
+
+# Handles notifications from the common window for script level windows
+# messages (see win.c)
+proc twapi::_script_wm_handler {msg wparam lparam msgpos ticks} {
+    variable _wm_registrations
+
+    set code 0
+    if {[info exists _wm_registrations($msg)]} {
+        foreach handler $_wm_registrations($msg) {
+            set code [catch {uplevel #0 [linsert $handler end $msg $wparam $lparam $msgpos $ticks]} msg]
+            switch -exact -- $code {
+                1 {
+                    # TBD - should remaining handlers be called even on error ?
+                    after 0 [list error $msg $::errorInfo $::errorCode]
+                    break
+                }
+                3 {
+                    break;      # Ignore remaining handlers
+                }
+                default {
+                    # Keep going
+                }
+            }
+        }
+    } else {
+        # TBD - debuglog - no handler for $msg
+    }
+
+    return
+}

src/punk86.vfs/lib/twapi4.7.2/winlog.tcl

@@ -0,0 +1,304 @@
+#
+# Copyright (c) 2012, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+# Routines to unify old and new Windows event log APIs
+
+namespace eval twapi {
+    # Dictionary to map eventlog consumer handles to various related info
+    # The primary key is the read handle to the event channel/source.
+    # Nested keys depend on OS version
+    variable _winlog_handles
+}
+
+proc twapi::winlog_open {args} {
+    variable _winlog_handles
+
+    # TBD - document -authtype
+    array set opts [parseargs args {
+        {system.arg ""}
+        channel.arg
+        file.arg
+        {authtype.arg 0}
+        {direction.arg forward {forward backward}}
+    } -maxleftover 0]
+
+    if {[info exists opts(file)] &&
+        ($opts(system) ne "" || [info exists opts(channel)])} {
+        error "Option '-file' cannot be used with '-channel' or '-system'"
+    } else {
+        if {![info exists opts(channel)]} {
+            set opts(channel) "Application"
+        }
+    }
+    
+    if {[min_os_version 6]} {
+        # Use new Vista APIs
+        if {[info exists opts(file)]} {
+            set hsess NULL
+            set hq [evt_query -file $opts(file) -ignorequeryerrors]
+        } else {
+            if {$opts(system) eq ""} {
+                set hsess [twapi::evt_local_session]
+            } else {
+                set hsess [evt_open_session $opts(system) -authtype $opts(authtype)]
+            }
+            # evt_query will not read new events from a channel once
+            # eof is reached. So if reading in forward direction, we use
+            # evt_subscribe. Backward it does not matter.
+            if {$opts(direction) eq "forward"} {
+                lassign [evt_subscribe $opts(channel) -session $hsess -ignorequeryerrors -includeexisting] hq signal
+                dict set _winlog_handles $hq signal $signal
+            } else {
+                set hq [evt_query -session $hsess -channel $opts(channel) -ignorequeryerrors -direction $opts(direction)]
+            }
+        }
+        
+        dict set _winlog_handles $hq session $hsess
+    } else {
+        if {[info exists opts(file)]} {
+            set hq [eventlog_open -file $opts(file)]
+            dict set _winlog_handles $hq channel $opts(file)
+        } else {
+            set hq [eventlog_open -system $opts(system) -source $opts(channel)]
+            dict set _winlog_handles $hq channel $opts(channel)
+        }
+        dict set _winlog_handles $hq direction $opts(direction)
+    }
+    return $hq
+}
+
+proc twapi::winlog_close {hq} {
+    variable _winlog_handles
+
+    if {! [dict exists $_winlog_handles $hq]} {
+        error "Invalid event consumer handler '$hq'"
+    }
+
+    if {[dict exists $_winlog_handles $hq signal]} {
+        # Catch in case app has closed event directly, for
+        # example when returned through winlog_subscribe
+        catch {close_handle [dict get $_winlog_handles $hq signal]}
+    }
+    if {[min_os_version 6]} {
+        set hsess [dict get $_winlog_handles $hq session]
+        evt_close $hq
+        evt_close_session $hsess
+    } else {
+        eventlog_close $hq
+    }
+
+    dict unset _winlog_handles $hq
+    return
+}
+
+proc twapi::winlog_event_count {args} {
+    # TBD - document and -authtype
+    array set opts [parseargs args {
+        {system.arg ""}
+        channel.arg
+        file.arg
+        {authtype.arg 0}
+    } -maxleftover 0]
+
+    if {[info exists opts(file)] &&
+        ($opts(system) ne "" || [info exists opts(channel)])} {
+        error "Option '-file' cannot be used with '-channel' or '-system'"
+    } else {
+        if {![info exists opts(channel)]} {
+            set opts(channel) "Application"
+        }
+    }
+
+    if {[min_os_version 6]} {
+        # Use new Vista APIs
+        trap {
+            if {[info exists opts(file)]} {
+                set hsess NULL
+                set hevl [evt_open_log_info -file $opts(file)]
+            } else {
+                if {$opts(system) eq ""} {
+                    set hsess [twapi::evt_local_session]
+                } else {
+                    set hsess [evt_open_session $opts(system) -authtype $opts(authtype)]
+                }
+                set hevl [evt_open_log_info -session $hsess -channel $opts(channel)]
+            }
+            return [lindex [evt_log_info $hevl -numberoflogrecords] 1]
+        } finally {
+            if {[info exists hsess]} {
+                evt_close_session $hsess
+            }
+            if {[info exists hevl]} {
+                evt_close $hevl
+            }
+        }
+    } else {
+        if {[info exists opts(file)]} {
+            set hevl [eventlog_open -file $opts(file)]
+        } else {
+            set hevl [eventlog_open -system $opts(system) -source $opts(channel)]
+        }
+
+        trap {
+            return [eventlog_count $hevl]
+        } finally {
+            eventlog_close $hevl
+        }
+    }
+}
+
+if {[twapi::min_os_version 6]} {
+
+    proc twapi::winlog_read {hq args} {
+        parseargs args {
+            {lcid.int 0}
+        } -setvars -maxleftover 0
+
+        # TBD - is 10 an appropriate number of events to read?
+        set events [evt_next $hq -timeout 0 -count 10 -status status]
+        if {[llength $events]} {
+            trap {
+                set result [evt_decode_events $events -lcid $lcid -ignorestring "" -message -levelname -taskname]
+            } finally {
+                evt_close {*}$events
+            }
+            return $result
+        }
+
+        # No events were returned. Check status whether it is fatal error
+        # or not. SUCCESS, NO_MORE_ITEMS, TIMEOUT, INVALID_OPERATION
+        # are acceptable. This last happens when another EvtNext is done
+        # after an NO_MORE_ITEMS is already returned.
+        if {$status == 0 || $status == 259 || $status == 1460 || $status == 4317} {
+            # Even though $events is empty, still pass it in so it returns
+            # an empty record array in the correct format.
+            return [evt_decode_events $events -lcid $lcid -ignorestring "" -message -levelname -taskname]
+        } else {
+            win32_error $status
+        }
+    }
+
+    proc twapi::winlog_subscribe {channelpath} {
+        variable _winlog_handles
+        lassign [evt_subscribe $channelpath -ignorequeryerrors] hq signal
+        dict set _winlog_handles $hq signal $signal
+        dict set _winlog_handles $hq session NULL; # local session
+        return [list $hq $signal]
+    }
+
+    interp alias {} twapi::winlog_clear {} twapi::evt_clear_log
+
+    proc twapi::winlog_backup {channel outpath} {
+        evt_export_log $outpath -channel $channel
+        return
+    }
+
+} else {
+
+    proc twapi::winlog_read {hq args} {
+        parseargs args {
+            {lcid.int 0}
+        } -setvars -maxleftover 0
+
+        variable _winlog_handles
+        set fields {-channel -taskname -message -providername -eventid -level -levelname -eventrecordid -computer -sid -timecreated}
+        set values {}
+        set channel [dict get $_winlog_handles $hq channel]
+        foreach evl [eventlog_read $hq -direction [dict get $_winlog_handles $hq direction]] {
+            # Note order must be same as fields above
+            lappend values \
+                [list \
+                     $channel \
+                     [eventlog_format_category $evl -langid $lcid] \
+                     [eventlog_format_message $evl -langid $lcid -width -1] \
+                     [dict get $evl -source] \
+                     [dict get $evl -eventid] \
+                     [dict get $evl -level] \
+                     [dict get $evl -type] \
+                     [dict get $evl -recordnum] \
+                     [dict get $evl -system] \
+                     [dict get $evl -sid] \
+                     [secs_since_1970_to_large_system_time [dict get $evl -timewritten]]]
+        }
+        return [list $fields $values]
+    }
+
+    proc twapi::winlog_subscribe {source} {
+        variable _winlog_handles
+        lassign [eventlog_subscribe $source] hq hevent
+        dict set _winlog_handles $hq channel $source
+        dict set _winlog_handles $hq direction forward
+        dict set _winlog_handles $hq signal $hevent
+        return [list $hq $hevent]
+    }
+
+    proc twapi::winlog_clear {source args} {
+        set hevl [eventlog_open -source $source]
+        trap {
+            eventlog_clear $hevl {*}$args
+        } finally {
+            eventlog_close $hevl
+        }
+        return
+    }
+
+    proc twapi::winlog_backup {source outpath} {
+        set hevl [eventlog_open -source $source]
+        trap {
+            eventlog_backup $hevl $outpath
+        } finally {
+            eventlog_close $hevl
+        }
+        return
+    }
+
+}
+
+
+proc twapi::_winlog_dump_list {{channels {Application System Security}} {atomize 0}} {
+    set evlist {}
+    foreach channel $channels {
+        set hevl [winlog_open -channel $channel]
+        trap {
+            while {[llength [set events [winlog_read $hevl]]]} {
+                foreach e [recordarray getlist $events -format dict] {
+                    if {$atomize} {
+                        dict set ev -message [atomize [dict get $e -message]]
+                        dict set ev -levelname [atomize [dict get $e -levelname]]
+                        dict set ev -channel [atomize [dict get $e -channel]]
+                        dict set ev -providername [atomize [dict get $e -providername]]
+                        dict set ev -taskname [atomize [dict get $e -taskname]]
+                        dict set ev -eventid [atomize [dict get $e -eventid]]
+                        dict set ev -account [atomize [dict get $e -userid]]
+                    } else {
+                        dict set ev -message [dict get $e -message]
+                        dict set ev -levelname [dict get $e -levelname]
+                        dict set ev -channel [dict get $e -channel]
+                        dict set ev -providername [dict get $e -providername]
+                        dict set ev -taskname [dict get $e -taskname]
+                        dict set ev -eventid [dict get $e -eventid]
+                        dict set ev -account [dict get $e -userid]
+                    }
+                    lappend evlist $ev
+                }
+            }
+        } finally {
+            winlog_close $hevl
+        }
+    }
+    return $evlist
+}
+
+proc twapi::_winlog_dump {{channel Application} {fd stdout}} {
+    set hevl [winlog_open -channel $channel]
+    while {[llength [set events [winlog_read $hevl]]]} {
+        # print out each record
+        foreach ev [recordarray getlist $events -format dict] {
+            puts $fd "[dict get $ev -timecreated] [dict get $ev -providername]: [dict get $ev -message]"
+        }
+    }
+    winlog_close $hevl
+}

src/punk86.vfs/lib/twapi4.7.2/winsta.tcl

@@ -0,0 +1,113 @@
+#
+# Copyright (c) 2004-2012, Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+
+# TBD - document and test
+proc twapi::get_active_console_tssession {} {
+    return [WTSGetActiveConsoleSessionId]
+}
+
+proc twapi::get_current_window_station_handle {} {
+    return [GetProcessWindowStation]
+}
+
+# Get the handle to a window station
+proc twapi::get_window_station_handle {winsta args} {
+    array set opts [parseargs args {
+        inherit.bool
+        {access.arg  generic_read}
+    } -nulldefault]
+
+    set access_rights [_access_rights_to_mask $opts(access)]
+    
+    return [OpenWindowStation $winsta $opts(inherit) $access_rights]
+}
+
+
+# Close a window station handle
+proc twapi::close_window_station_handle {hwinsta} {
+    # Trying to close our window station handle will generate an error
+    if {$hwinsta != [get_current_window_station_handle]} {
+        CloseWindowStation $hwinsta
+    }
+    return
+}
+
+# List all window stations
+proc twapi::find_window_stations {} {
+    return [EnumWindowStations]
+}
+
+
+# Enumerate desktops in a window station
+proc twapi::find_desktops {args} {
+    array set opts [parseargs args {winsta.arg}]
+
+    if {[info exists opts(winsta)]} {
+        set hwinsta [get_window_station_handle $opts(winsta)]
+    } else {
+        set hwinsta [get_current_window_station_handle]
+    }
+
+    trap {
+        return [EnumDesktops $hwinsta]
+    } finally {
+        # Note close_window_station_handle protects against
+        # hwinsta being the current window station handle so 
+        # we do not need to do that check here
+        close_window_station_handle $hwinsta
+    }
+}
+
+
+# Get the handle to a desktop
+proc twapi::get_desktop_handle {desk args} {
+    array set opts [parseargs args {
+        inherit.bool
+        allowhooks.bool
+        {access.arg  generic_read}
+    } -nulldefault]
+
+    set access_mask [_access_rights_to_mask $opts(access)]
+    
+    # If certain access rights are specified, we must add certain other
+    # access rights. See OpenDesktop SDK docs
+    set access_rights [_access_mask_to_rights $access_mask]
+    if {"read_control" in $access_rights ||
+        "write_dacl" in $access_rights ||
+        "write_owner" in  $access_rights} {
+        lappend access_rights desktop_readobject desktop_writeobjects
+        set access_mask [_access_rights_to_mask $opts(access)]
+    }
+
+    return [OpenDesktop $desk $opts(allowhooks) $opts(inherit) $access_mask]
+}
+
+# Close the desktop handle
+proc twapi::close_desktop_handle {hdesk} {
+    CloseDesktop $hdesk
+}
+
+# Set the process window station
+proc twapi::set_process_window_station {hwinsta} {
+    SetProcessWindowStation $hwinsta
+}
+
+proc twapi::get_desktop_user_sid {hdesk} {
+    return [GetUserObjectInformation $hdesk 4]
+}
+
+proc twapi::get_window_station_user_sid {hwinsta} {
+    return [GetUserObjectInformation $hwinsta 4]
+}
+
+proc twapi::get_desktop_name {hdesk} {
+    return [GetUserObjectInformation $hdesk 2]
+}
+
+proc twapi::get_window_station_name {hwinsta} {
+    return [GetUserObjectInformation $hwinsta 2]
+}

src/punk86.vfs/lib/twapi4.7.2/wmi.tcl

@@ -0,0 +1,223 @@
+#
+# Copyright (c) 2012 Ashok P. Nadkarni
+# All rights reserved.
+#
+# See the file LICENSE for license
+
+package require twapi_com
+
+# TBD - document?
+
+twapi::class create ::twapi::IMofCompilerProxy {
+    superclass ::twapi::IUnknownProxy
+
+    constructor {args} {
+        if {[llength $args] == 0} {
+            set args [list [::twapi::com_create_instance "{6daf9757-2e37-11d2-aec9-00c04fb68820}" -interface IMofCompiler -raw]]
+        }
+        next {*}$args
+    }
+
+    method CompileBuffer args {
+        my variable _ifc
+        return [::twapi::IMofCompiler_CompileBuffer $_ifc {*}$args]
+    }
+
+    method CompileFile args {
+        my variable _ifc
+        return [::twapi::IMofCompiler_CompileFile $_ifc {*}$args]
+    }
+
+    method CreateBMOF args {
+        my variable _ifc
+        return [::twapi::IMofCompiler_CreateBMOF $_ifc {*}$args]
+    }
+
+    twapi_exportall
+}
+
+
+#
+# Get WMI service - TBD document
+proc twapi::wmi_root {args} {
+    array set opts [parseargs args {
+        {root.arg cimv2}
+        {impersonationlevel.arg impersonate {default anonymous identify delegate impersonate} }
+    } -maxleftover 0]
+
+    # TBD - any injection attacks possible ? Need to quote ?
+    return [comobj_object "winmgmts:{impersonationLevel=$opts(impersonationlevel)}!//./root/$opts(root)"]
+}
+# Backwards compat
+proc twapi::_wmi {{top cimv2}} {
+    return [wmi_root -root $top]
+}
+
+# TBD - see if using ExecQuery would be faster if it supports all the options
+proc twapi::wmi_collect_classes {swbemservices args} {
+    array set opts [parseargs args {
+        {ancestor.arg {}}
+        shallow
+        first
+        matchproperties.arg
+        matchsystemproperties.arg
+        matchqualifiers.arg
+        {collector.arg {lindex}}
+    } -maxleftover 0]
+    
+    
+    # Create a forward only enumerator for efficiency
+    # wbemFlagUseAmendedQualifiers | wbemFlagReturnImmediately | wbemFlagForwardOnly
+    set flags 0x20030
+    if {$opts(shallow)} {
+        incr flags 1;           # 0x1 -> wbemQueryFlagShallow
+    }
+
+    set classes [$swbemservices SubclassesOf $opts(ancestor) $flags]
+    set matches {}
+    set delete_on_error {}
+    twapi::trap {
+        $classes -iterate class {
+            set matched 1
+            foreach {opt fn} {
+                matchproperties Properties_
+                matchsystemproperties SystemProperties_
+                matchqualifiers Qualifiers_
+            } {
+                if {[info exists opts($opt)]} {
+                    foreach {name matcher} $opts($opt) {
+                        if {[catch {
+                            if {! [{*}$matcher [$class -with [list [list -get $fn] [list Item $name]] Value]]} {
+                                set matched 0
+                                break; # Value does not match
+                            }
+                        } msg ]} {
+                            # TBD - log debug error if not property found
+                            # No such property or no access
+                            set matched 0
+                            break
+                        }
+                    }
+                }
+                if {! $matched} {
+                    # Already failed to match, no point continuing looping
+                    break
+                }
+            }
+
+            if {$matched} {
+                # Note collector code is responsible for disposing
+                # of $class as appropriate. But we take care of deleting
+                # when an error occurs after some accumulation has
+                # already occurred.
+                lappend delete_on_error $class
+                if {$opts(first)} {
+                    return [{*}$opts(collector) $class]
+                } else {
+                    lappend matches [{*}$opts(collector) $class]
+                }
+            } else {
+                $class destroy
+            }
+        }
+    } onerror {} {
+        foreach class $delete_on_error {
+            if {[comobj? $class]} {
+                $class destroy
+            }
+        }
+        rethrow
+    } finally {
+        $classes destroy
+    }
+
+    return $matches
+}
+
+proc twapi::wmi_extract_qualifier {qual} {
+    foreach prop {name value isamended propagatestoinstance propagatestosubclass isoverridable} {
+        dict set result $prop [$qual -get $prop]
+    }
+    return $result
+}
+
+proc twapi::wmi_extract_property {propobj} {
+    foreach prop {name value cimtype isarray islocal origin} {
+        dict set result $prop [$propobj -get $prop]
+    }
+
+    $propobj -with Qualifiers_ -iterate -cleanup qual {
+        set rec [wmi_extract_qualifier $qual]
+        dict set result qualifiers [string tolower [dict get $rec name]] $rec
+    }
+
+    return $result
+}
+
+proc twapi::wmi_extract_systemproperty {propobj} {
+    # Separate from wmi_extract_property because system properties do not
+    # have Qualifiers_
+    foreach prop {name value cimtype isarray islocal origin} {
+        dict set result $prop [$propobj -get $prop]
+    }
+
+    return $result
+}
+
+
+proc twapi::wmi_extract_method {mobj} {
+    foreach prop {name origin} {
+        dict set result $prop [$mobj -get $prop]
+    }
+
+    # The InParameters and OutParameters properties are SWBEMObjects
+    # the properties of which describe the parameters.
+    foreach inout {inparameters outparameters} {
+        set paramsobj [$mobj -get $inout]
+        if {[$paramsobj -isnull]} {
+            dict set result $inout {}
+        } else {
+            $paramsobj -with Properties_ -iterate -cleanup pobj {
+                set rec [wmi_extract_property $pobj]
+                dict set result $inout [string tolower [dict get $rec name]] $rec
+            }
+        }
+    }
+
+    $mobj -with Qualifiers_ -iterate qual {
+        set rec [wmi_extract_qualifier $qual]
+        dict set result qualifiers [string tolower [dict get $rec name]] $rec
+        $qual destroy
+    }
+
+    return $result
+}
+
+
+proc twapi::wmi_extract_class {obj} {
+    
+    set result [dict create]
+
+    # Class qualifiers
+    $obj -with Qualifiers_ -iterate -cleanup qualobj {
+        set rec [wmi_extract_qualifier $qualobj]
+        dict set result qualifiers [string tolower [dict get $rec name]] $rec
+    }
+
+    $obj -with Properties_ -iterate -cleanup propobj {
+        set rec [wmi_extract_property $propobj]
+        dict set result properties [string tolower [dict get $rec name]] $rec
+    }
+
+    $obj -with SystemProperties_ -iterate -cleanup propobj {
+        set rec [wmi_extract_systemproperty $propobj]
+        dict set result systemproperties [string tolower [dict get $rec name]] $rec
+    }
+    
+    $obj -with Methods_ -iterate -cleanup mobj {
+        set rec [wmi_extract_method $mobj]
+        dict set result methods [string tolower [dict get $rec name]] $rec
+    }
+
+    return $result
+}

src/punk86.vfs/main.tcl

@@ -0,0 +1,9 @@
+
+  package require starkit
+  starkit::startup
+  if {[llength $::argv]} {
+    package require app-shellspy
+  } else {
+    package require app-punk
+  }
+

src/tclkit86bi.vfs/boot.tcl

@@ -0,0 +1,127 @@
+proc tclInit {} {
+    rename tclInit {}
+
+    global auto_path tcl_library tcl_libPath tcl_version tclkit_system_encoding
+
+    # find the file to mount.
+    set noe $::tcl::kitpath
+    # resolve symlinks
+    set noe [file dirname [file normalize [file join $noe __dummy__]]]
+    set tcl_library [file join $noe lib tcl$tcl_version]
+    set tcl_libPath [list $tcl_library [file join $noe lib]]
+
+    # get rid of a build residue
+    unset -nocomplain ::tclDefaultLibrary
+
+    # The following code only gets executed if we don't have our exe
+    # already mounted.  This should only happen once per thread.
+    # We could use [vfs::filesystem info], but that would require
+    # loading vfs into every interp.
+    if {![file isdirectory $noe]} {
+        load {} vfs
+
+        # lookup and emulate "source" of lib/vfs1*/{vfs*.tcl,mk4vfs.tcl}
+        if {[llength [info command mk::file]]} {
+            set driver mk4
+
+            # must use raw Metakit calls because VFS is not yet in place
+            set d [mk::select exe.dirs parent 0 name lib]
+            set d [mk::select exe.dirs parent $d -glob name vfs1*]
+            
+            foreach x {vfsUtils vfslib mk4vfs} {
+                set n [mk::select exe.dirs!$d.files name $x.tcl]
+                if {[llength $n] != 1} { error "$x: cannot find startup script"}
+                
+                set s [mk::get exe.dirs!$d.files!$n contents]
+                catch {set s [zlib decompress $s]}
+                uplevel #0 $s
+            }
+
+            # use on-the-fly decompression, if mk4vfs understands that
+            # Note: 8.6 core zlib does not support this for mk4vfs
+            if {![package vsatisfies [package require Tcl] 8.6]} {
+                set mk4vfs::zstreamed 1
+            }
+        } else {
+            set driver mkcl
+
+            # use raw Vlerq calls if Mk4tcl is not available
+            # $::vlerq::starkit_root is set in the init script in kitInit.c
+            set rootv [vlerq get $::vlerq::starkit_root 0 dirs]
+            set dname [vlerq get $rootv * name]
+            set prows [vlerq get $rootv * parent]
+            foreach r [lsearch -int -all $prows 0] {
+                if {[lindex $dname $r] eq "lib"} break
+            }
+            
+            # glob for a subdir in "lib", then source the specified file inside it
+            foreach {d f} {
+                vfs1* vfsUtils.tcl vfs1* vfslib.tcl vqtcl4* mkclvfs.tcl
+            } {
+                foreach z [lsearch -int -all $prows $r] {
+                    if {[string match $d [lindex $dname $z]]} break
+                }
+
+                set files [vlerq get $rootv $z files]
+                set names [vlerq get $files * name]
+
+                set n [lsearch $names $f]
+                if {$n < 0} { error "$d/$f: cannot find startup script"}
+                
+                set s [vlerq get $files $n contents]
+                catch {set s [zlib decompress $s]}
+                uplevel #0 $s
+            }
+
+            # hack the mkcl info so it will know this mount point as "exe"
+            set vfs::mkcl::v::rootv(exe) $rootv
+            set vfs::mkcl::v::dname(exe) $dname
+            set vfs::mkcl::v::prows(exe) $prows
+        }
+
+        # mount the executable, i.e. make all runtime files available
+        vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe]
+
+        # alter path to find encodings
+        if {[info tclversion] eq "8.4"} {
+            load {} pwb
+            librarypath [info library]
+        } else {
+            encoding dirs [list [file join [info library] encoding]] ;# TIP 258
+        }
+        # if the C code passed us a system encoding, apply it here.
+        if {[info exists tclkit_system_encoding]} {
+            # It is possible the chosen encoding is unavailable in which case
+            # we will be left with 'identity' to be handled below.
+            catch {encoding system $tclkit_system_encoding}
+            unset tclkit_system_encoding
+        }
+        # fix system encoding, if it wasn't properly set up (200207.004 bug)
+        if {[encoding system] eq "identity"} {
+            switch $::tcl_platform(platform) {
+                windows		{ encoding system cp1252 }
+                macintosh	{ encoding system macRoman }
+                default		{ encoding system iso8859-1 }
+            }
+        }
+
+        # now remount the executable with the correct encoding
+        vfs::filesystem unmount $noe
+        set noe $::tcl::kitpath
+        # resolve symlinks
+        set noe [file dirname [file normalize [file join $noe __dummy__]]]
+
+        set tcl_library [file join $noe lib tcl$tcl_version]
+        set tcl_libPath [list $tcl_library [file join $noe lib]]
+        vfs::filesystem mount $noe [list ::vfs::${driver}::handler exe]
+    }
+    
+    # load config settings file if present
+    namespace eval ::vfs { variable tclkit_version 1 }
+    catch { uplevel #0 [list source [file join $noe config.tcl]] }
+
+    uplevel #0 [list source [file join $tcl_library init.tcl]]
+    
+    # reset auto_path, so that init.tcl's search outside of tclkit is cancelled
+    set auto_path $tcl_libPath
+}

src/tclkit86bi.vfs/lib/Ffidl0.9.0/ffidlrt.tcl

@@ -0,0 +1,333 @@
+#
+# Ffidl interface to Tcl8.2
+#
+# Run time support for Ffidl.
+#
+# NOTE: Remember to update FFIDLRT_VERSION in configure.ac when changing this
+#       version number.
+package provide Ffidlrt 0.4
+package require Ffidl
+
+namespace eval ::ffidl:: {}
+
+proc ::ffidl::find-pkg-lib {pkg} {
+    package require $pkg
+    foreach i [::info loaded {}] {
+        foreach {l p} $i {}
+        if {$p eq "$pkg"} {
+            return $l
+        }
+    }
+    # ignore errors when running under pkg_mkIndex:
+    if {![llength [info commands __package_orig]] } {
+        return -code error "Library for package $pkg not found"
+    }
+}
+
+namespace eval ::ffidl:: {
+    set ffidl_lib [find-pkg-lib Ffidl]
+    array set libs [list ffidl [list $ffidl_lib] ffidl_test [list $ffidl_lib]]
+    unset ffidl_lib
+    
+    # 'libs' array is used by the ::ffidl::find-lib
+    # abstraction to store the resolved lib paths
+    #
+    # 'types' and 'typedefs' arrays are used by the ::ffidl::find-type
+    # abstraction to store resolved system types
+    # and whether they have already been defined
+    # with ::ffidl::typedef
+    array set typedefs {}
+    switch -exact $tcl_platform(platform) {
+	unix {
+	    switch -glob $tcl_platform(os) {
+                Darwin {
+                    array set libs {
+                        c System.framework/System
+                        m System.framework/System
+                        gdbm {}
+                        gmp {}
+                        mathswig libmathswig0.5.dylib
+                    }
+                    array set types {
+                        size_t {{unsigned long}}
+                        clock_t {{unsigned long}}
+                        time_t long
+                        timeval {uint32 uint32}
+                    }
+                }
+                Linux {
+                    if {$tcl_platform(wordSize) == 8} {
+                        if {$tcl_platform(machine) eq "alpha"} {
+                            array set libs {
+                                c /lib/libc.so.6.1
+                                m /lib/libm.so.6.1
+                                gdbm /usr/lib/libgdbm.so
+                                gmp {/usr/local/lib/libgmp.so /usr/lib/libgmp.so.2}
+                                mathswig libmathswig0.5.so
+                            }
+                            array set types {
+                                size_t long
+                                clock_t long
+                                time_t long
+                                timeval {time_t time_t}
+                            }                        
+                        } else {
+                            array set libs {
+                                c {
+				    /lib64/libc.so.6
+				    /lib/x86_64-linux-gnu/libc.so.6
+				}
+                                m {
+				    /lib64/libm.so.6
+				    /lib/x86_64-linux-gnu/libm.so.6
+				}
+                                gdbm {
+				    /usr/lib64/libgdbm.so
+				    /usr/lib/x86_64-linux-gnu/libgdbm.so
+				}
+                                gmp {
+				    /usr/lib/x86_64-linux-gnu/libgmp.so
+				    /usr/local/lib64/libgmp.so
+				    /usr/lib64/libgmp.so.2
+				}
+                                mathswig libmathswig0.5.so
+                            }
+                            array set types {
+                                size_t long
+                                clock_t long
+                                time_t long
+                                timeval {time_t time_t}
+                            }
+                        }
+                    } else {
+                        array set libs {
+                            c {
+                                    /lib/libc.so.6
+                                    /lib/i386-linux-gnu/libc.so.6
+                            }
+                            m {
+                                    /lib/libm.so.6
+                                    /lib/i386-linux-gnu/libm.so.6
+                            }
+                            gdbm {
+                                    /usr/lib/libgdbm.so
+                                    /usr/lib/i386-linux-gnu/libgdbm.so.3
+                            }
+                            gmp {
+                                   /usr/lib/i386-linux-gnu/libgmp.so.2
+                                   /usr/local/lib/libgmp.so
+                                   /usr/lib/libgmp.so.2
+                            }
+                            mathswig libmathswig0.5.so
+                        }
+                        array set types {
+                            size_t int
+                            clock_t long
+                            time_t long
+                            timeval {time_t time_t}
+                        }
+                    }
+                }
+                *BSD {
+                    array set libs {
+                        c {/usr/lib/libc.so /usr/lib/libc.so.30.1}
+                        m {/usr/lib/libm.so /usr/lib/libm.so.1.0}
+                        gdbm libgdbm.so
+                        gmp libgmp.so
+                        mathswig libmathswig0.5.so
+                    }
+                    array set types {
+                        size_t int
+                        clock_t long
+                        time_t long
+                        timeval {time_t time_t}
+                    }
+                }
+                default {
+                    array set libs {
+                        c /lib/libc.so
+                        m /lib/libm.so
+                        gdbm libgdbm.so
+                        gmp libgmp.so
+                        mathswig libmathswig0.5.so
+                    }
+                    array set types {
+                        size_t int
+                        clock_t long
+                        time_t long
+                        timeval {time_t time_t}
+                    }
+                }
+	    }
+	}
+	windows {
+            #
+            # found libraries
+            # this array is used by the ::ffidl::find-lib
+            # abstraction to store the resolved lib paths
+            #
+            # CHANGE - put your resolved lib paths here
+            #
+	    array set libs {
+		c msvcrt.dll
+		m msvcrt.dll
+		gdbm {}
+		gmp gmp202.dll
+		mathswig mathswig05.dll
+	    }
+            #
+            # found types
+            # these arrays are used by the ::ffidl::find-type
+            # abstraction to store resolved system types
+            # and whether they have already been defined
+            # with ::ffidl::typedef
+            #
+            # CHANGE - put your resolved system types here
+            #
+            array set types {
+                size_t int
+                clock_t long
+                time_t long
+                timeval {time_t time_t}
+            }
+            array set typedefs {
+            }
+	}
+    }
+}
+
+#
+# find a shared library given a root name
+# this is an abstraction in search of a
+# solution.
+#
+# currently wired for my linux box
+#
+proc ::ffidl::find-lib {root} {
+    upvar \#0 ::ffidl::libs libs
+    if { ! [::info exists libs($root)] || [llength libs($root)] == 0} {
+	error "::ffidl::find-lib $root - no mapping defined for $root"
+    }
+    if {[llength $libs($root)] > 1} {
+	foreach l $libs($root) {
+	    if {[file exists $l]} {
+		set libs($root) $l
+		break
+	    }
+	}
+    }
+    lindex $libs($root) 0
+}
+
+#
+# find a typedef for a standard type
+# and define it with ::ffidl::typedef
+# if not already done
+#
+# currently wired for my linux box
+#
+proc ::ffidl::find-type {type} {
+    upvar \#0 ::ffidl::types types
+    upvar \#0 ::ffidl::typedefs typedefs
+    if { ! [::info exists types($type)]} {
+	error "::ffidl::find-type $type - no mapping defined for $type"
+    }
+    if { ! [::info exists typedefs($type)]} {
+	eval ::ffidl::typedef $type $types($type)
+	set typedefs($type) 1
+    }
+}
+    
+#
+# get the address of the string rep of a Tcl_Obj
+# get the address of the unicode rep of a Tcl_Obj
+# get the address of the bytearray rep of a Tcl_Obj
+#
+# CAUTION - anything which alters the Tcl_Obj may
+# invalidate the results of this function.  Use
+# only in circumstances where the Tcl_Obj will not
+# be modified in any way.
+#
+# CAUTION - the memory pointed to by the addresses
+# returned by ::ffidl::get-string and ::ffidl::get-unicode
+# is managed by Tcl, the contents should never be
+# modified.
+#
+# The memory pointed to by ::ffidl::get-bytearray may
+# be modified if care is taken to respect its size,
+# and if shared references to the bytearray object
+# are known to be compatible with the modification.
+#
+
+::ffidl::callout ::ffidl::get-string {pointer-obj} pointer [::ffidl::stubsymbol tcl stubs 340]; #Tcl_GetString
+::ffidl::callout ::ffidl::get-unicode {pointer-obj} pointer [::ffidl::stubsymbol tcl stubs 382]; #Tcl_GetUnicode
+::ffidl::callout ::ffidl::get-bytearray-from-obj {pointer-obj pointer-var} pointer [::ffidl::stubsymbol tcl stubs 33]; #Tcl_GetByteArrayFromObj
+
+proc ::ffidl::get-bytearray {obj} {
+    set len [binary format [::ffidl::info format int] 0]
+    ::ffidl::get-bytearray-from-obj $obj len
+}
+
+#
+# create a new string Tcl_Obj
+# create a new unicode Tcl_Obj
+# create a new bytearray Tcl_Obj
+#
+# I'm not sure if these are actually useful
+#
+
+::ffidl::callout ::ffidl::new-string {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 56]; #Tcl_NewStringObj
+::ffidl::callout ::ffidl::new-unicode {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 378]; #Tcl_NewUnicodeObj
+::ffidl::callout ::ffidl::new-bytearray {pointer int} pointer-obj [::ffidl::stubsymbol tcl stubs 50]; #Tcl_NewByteArrayObj
+
+::ffidl::find-type size_t
+if {1} {
+    # Tcl's allocator: malloc, free, realloc.
+    ::ffidl::callout ::ffidl::malloc {unsigned} pointer [::ffidl::stubsymbol tcl stubs 3]; #Tcl_Alloc
+    ::ffidl::callout ::ffidl::realloc {pointer unsigned} pointer [::ffidl::stubsymbol tcl stubs 5]; #Tcl_Realloc
+    ::ffidl::callout ::ffidl::free {pointer} void [::ffidl::stubsymbol tcl stubs 4]; #Tcl_Free
+} else {
+    # access the standard allocator: malloc, free, realloc.
+    ::ffidl::callout ::ffidl::malloc {size_t} pointer [::ffidl::symbol [::ffidl::find-lib c] malloc]
+    ::ffidl::callout ::ffidl::realloc {pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib c] realloc]
+    ::ffidl::callout ::ffidl::free {pointer} void [::ffidl::symbol [::ffidl::find-lib c] free]
+}
+
+#
+# Copy some memory at some location into a Tcl bytearray.
+#
+# Needless to say, this can be very hazardous to your
+# program's health if things aren't sized correctly.
+#
+::ffidl::callout ::ffidl::memcpy {pointer-var pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_copy_bytes];
+
+#
+# Regular memcpy working on pointers.  ::ffidl::memcpy kept as is for compatibilitiy.
+#
+::ffidl::callout ::ffidl::memcpy2 {pointer pointer size_t} pointer [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_copy_bytes];
+
+#
+# Create a Tcl bytearray with a copy of the contents some memory location.
+#
+proc ::ffidl::peek {address nbytes} {
+    set dst [binary format x$nbytes]
+    ::ffidl::memcpy dst $address $nbytes
+    set dst
+}
+
+#
+# Copy the contents of a Tcl bytearray to some memory location.
+#
+proc ::ffidl::poke {dst src} {
+    set n [string length $bytes];
+    set src [::ffidl::get-bytearray $bytes];
+    ::ffidl::memcpy2 $dst $src $n;
+}
+
+#
+# convert raw pointers, as integers, into Tcl_Obj's
+#
+::ffidl::callout ::ffidl::pointer-into-string {pointer} pointer-utf8 [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_pointer_pun]
+::ffidl::callout ::ffidl::pointer-into-unicode {pointer} pointer-utf16 [::ffidl::symbol [::ffidl::find-lib ffidl] ffidl_pointer_pun]
+# ::ffidl::pointer-into-bytearray is deprecated. Use ::ffidl::peek instead.
+interp alias {} ::ffidl::pointer-into-bytearray {} ::ffidl::peek;

src/tclkit86bi.vfs/lib/Ffidl0.9.0/pkgIndex.tcl

@@ -0,0 +1,12 @@
+# Tcl package index file, version 1.1
+# This file is generated by the "pkg_mkIndex" command
+# and sourced either when an application starts up or
+# by a "package unknown" script.  It invokes the
+# "package ifneeded" command to set up package-related
+# information so that packages will be loaded automatically
+# in response to "package require" commands.  When this
+# script is sourced, the variable $dir must contain the
+# full path name of this file's directory.
+
+package ifneeded Ffidl 0.9.0 [list load [file join $dir Ffidl090.dll]]
+package ifneeded Ffidlrt 0.4 [list source [file join $dir ffidlrt.tcl]]

src/tclkit86bi.vfs/lib/Memchan2.3/pkgIndex.tcl

@@ -0,0 +1,2 @@
+package ifneeded Memchan 2.3 \
+    [list load [file join $dir Memchan23.dll]]

src/tclkit86bi.vfs/lib/Trf2.1.4/pkgIndex.tcl

@@ -0,0 +1,2 @@
+package ifneeded Trf 2.1.4 \
+    [list load [file join $dir Trf214.dll]]

src/tclkit86bi.vfs/lib/cffi1.2.0/pkgIndex.tcl

@@ -0,0 +1,29 @@
+#
+# Tcl package index file - generated from pkgIndex.tcl.in
+#
+
+package ifneeded cffi 1.2.0 \
+    [list apply [list {dir} {
+        set dllname "tclcffi120.dll"
+        set package "cffi"
+        set package_ns ::$package
+
+        # First try to load from current directory. If that fails, try from
+        # arch-specific subdirectories
+        set path [file join $dir $dllname]
+        if {[catch {uplevel #0 [list load $path $package]}]} {
+            package require platform
+            foreach platform [platform::patterns [platform::identify]] {
+                if {$platform eq "tcl"} continue
+                set path [file join $dir $platform $dllname]
+                if {![catch {uplevel #0 [list load $path $package]}]} {
+                    break
+                }
+            }
+        }
+        if {[namespace exists $package_ns]} {
+            # Load was successful
+            set ${package_ns}::dll_path $path
+            set ${package_ns}::package_dir $dir
+        }
+    }] $dir]

src/tclkit86bi.vfs/lib/critcl-app3.2/pkgIndex.tcl

@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.6]} {return}
+package ifneeded critcl::app 3.2 [list source [file join $dir critcl.tcl]]

src/tclkit86bi.vfs/lib/critcl-app3.2/runtime.tcl

@@ -0,0 +1,134 @@
+#
+#   Critcl - build C extensions on-the-fly
+#
+#   Copyright (c) 2001-2007 Jean-Claude Wippler
+#   Copyright (c) 2002-2007 Steve Landers
+#
+#   See http://wiki.tcl.tk/critcl
+#
+#   This is the Critcl runtime that loads the appropriate
+#   shared library when a package is requested
+#
+
+namespace eval ::critcl::runtime {}
+
+proc ::critcl::runtime::loadlib {dir package version libname initfun tsrc mapping args} {
+    # XXX At least parts of this can be done by the package generator,
+    # XXX like listing the Tcl files to source. The glob here allows
+    # XXX code-injection after-the-fact, by simply adding a .tcl in
+    # XXX the proper place.
+    set path [file join $dir [MapPlatform $mapping]]
+    set ext [info sharedlibextension]
+    set lib [file join $path $libname$ext]
+    set provide [list]
+
+    # Now the runtime equivalent of a series of 'preFetch' commands.
+    if {[llength $args]} {
+	set preload [file join $path preload$ext]
+	foreach p $args {
+	    set prelib [file join $path $p$ext]
+	    if {[file readable $preload] && [file readable $prelib]} {
+		lappend provide [list load $preload];# XXX Move this out of the loop, do only once.
+		lappend provide [list ::critcl::runtime::preload $prelib]
+	    }
+	}
+    }
+
+    lappend provide [list load $lib $initfun]
+    foreach t $tsrc {
+	lappend loadcmd "::critcl::runtime::Fetch \$dir [list $t]"
+    }
+    lappend provide "package provide $package $version"
+    package ifneeded $package $version [join $provide "\n"]
+    return
+}
+
+proc ::critcl::runtime::preFetch {path ext dll} {
+    set preload [file join $path preload$ext]
+    if {![file readable $preload]} return
+
+    set prelib [file join $path $dll$ext]
+    if {![file readable $prelib]} return
+
+    load $preload ; # Defines next command.
+    ::critcl::runtime::preload $prelib
+    return
+}
+
+proc ::critcl::runtime::Fetch {dir t} {
+    # The 'Ignore' disables compile & run functionality.
+
+    # Background: If the regular critcl package is already loaded, and
+    # this prebuilt package uses its defining .tcl file also as a
+    # 'tsources' then critcl might try to collect data and build it
+    # because of the calls to its API, despite the necessary binaries
+    # already being present, just not in the critcl cache. That is
+    # redundant in the best case, and fails in the worst case (no
+    # compiler), preventing the use o a perfectly fine package. The
+    # 'ignore' call now tells critcl that it should ignore any calls
+    # made to it by the sourced files, and thus avoids that trouble.
+
+    # The other case, the regular critcl package getting loaded after
+    # this prebuilt package is irrelevant. At that point the tsources
+    # were already run, and used the dummy procedures defined in the
+    # critcl-rt.tcl, which ignore the calls by definition.
+
+    set t [file join $dir tcl $t]
+    ::critcl::Ignore $t
+    uplevel #0 [list source $t]
+    return
+}
+
+proc ::critcl::runtime::precopy {dll} {
+    # This command is only used on Windows when preloading out of a
+    # VFS that doesn't support direct loading (usually, a Starkit)
+    #   - we preserve the dll name so that dependencies are satisfied
+    #	- The critcl::runtime::preload command is defined in the supporting
+    #     "preload" package, implemented in "critcl/lib/critcl/critcl_c/preload.c"
+
+    global env
+    if {[info exists env(TEMP)]} {
+	set dir $env(TEMP)
+    } elseif {[info exists env(TMP)]} {
+	set dir $env(TMP)
+    } elseif {[info exists ~]} {
+	set dir ~
+    } else {
+	set dir .
+    }
+    set dir [file join $dir TCL[pid]]
+    set i 0
+    while {[file exists $dir]} {
+	append dir [incr i]
+    }
+    set new [file join $dir [file tail $dll]]
+    file mkdir $dir
+    file copy $dll $new
+    return $new
+}
+
+proc ::critcl::runtime::MapPlatform {{mapping {}}} {
+    # A sibling of critcl::platform that applies the platform mapping
+
+    set platform [::platform::generic]
+    set version $::tcl_platform(osVersion)
+    if {[string match "macosx-*" $platform]} {
+	# "normalize" the osVersion to match OSX release numbers
+	set v [split $version .]
+	set v1 [lindex $v 0]
+	set v2 [lindex $v 1]
+	incr v1 -4
+	set version 10.$v1.$v2
+    } else {
+	# Strip trailing non-version info
+	regsub -- {-.*$} $version {} version
+    }
+    foreach {config map} $mapping {
+	if {![string match $config $platform]} continue
+	set minver [lindex $map 1]
+	if {[package vcompare $version $minver] < 0} continue
+	set platform [lindex $map 0]
+	break
+    }
+    return $platform
+}

src/tclkit86bi.vfs/lib/critcl-app3.2/tea/Config.in

@@ -0,0 +1,188 @@
+## -*- tcl -*- Critcl configuration file
+# # ## ### ##### ######## ############# #####################
+## For
+# 	@@PNAME@@ @@PMAJORV@@.@@PMINORV@@
+#
+# Copyright (c) @@YEAR@@ @@PORG@@
+#
+# Generated by @@CRITCL@@
+# At           @@NOW@@
+
+# This specific file gets filled by the TEA configure(.in) with the
+# compiler information it found when run, and the accompanying
+# Makefile(.in) uses it to overide critcl's default configuration
+# settings. In this way we manage to get a proper TEA setup of flags
+# and such, bypassing all of critcl's own selection logic. critcl is
+# essentially 'just' used as a custom compiler driver, whereas a
+# standard TEA Makefile would have all the relevant commands listed
+# explicitly in its rules.
+
+# # ## ### ##### ######## ############# #####################
+## First, keep the GCC specific defaults.
+
+compile         gcc -c -fPIC
+version         gcc -v
+link            gcc -shared
+include         -I
+preproc_define  gcc -E -dM
+preproc_enum    gcc -E
+tclstubs        -DUSE_TCL_STUBS
+tkstubs         -DUSE_TK_STUBS
+debug_memory    -DTCL_MEM_DEBUG
+debug_symbols   -g
+object          .o
+output          -o [list $outfile]
+ldoutput
+link_debug
+link_release
+link_preload    --unresolved-symbols=ignore-in-shared-libs
+strip           -Wl,-s
+optimize        -O2
+noassert        -DNDEBUG
+threadflags     -DUSE_THREAD_ALLOC=1 -D_REENTRANT=1 -D_THREAD_SAFE=1    \
+                -DHAVE_PTHREAD_ATTR_SETSTACKSIZE=1 -DHAVE_READDIR_R=1   \
+                -DTCL_THREADS=1
+
+
+# # ## ### ##### ######## ############# #####################
+## Second, define settings based on the system information found by
+## configure(.in), converted into something usable by critcl. See the
+## section below for the raw settings.
+
+TEA platform        @CRITCL_PLATFORM@
+TEA compile         @CRITCL_CC@
+TEA version         @CRITCL_VERSION@
+TEA link            @CRITCL_LINK@
+TEA preproc_define  @CRITCL_CPP_DEFINE@
+TEA preproc_enum    @CRITCL_CPP_ENUM@
+TEA debug_symbols   @CFLAGS_DEBUG@
+TEA object          .@OBJEXT@
+TEA output          @CRITCL_CC_OUTPUT@
+TEA ldoutput        @CRITCL_LD_OUTPUT@
+TEA link_debug      @CRITCL_LD_DBG@
+TEA link_release    @CRITCL_LD_REL@
+TEA link_preload    --unresolved-symbols=ignore-in-shared-libs
+TEA strip           
+TEA optimize        @CFLAGS_OPTIMIZE@
+
+
+# # ## ### ##### ######## ############# #####################
+## Third, the exact raw settings generated by configure(.in),
+## as found in build_dir/config.status. To help debugging the
+## munging, when its wrong.
+##
+## The lines marked with ** are those which are of especially high
+## interest.
+
+#**	CC			= (@CC@)
+#**	CFLAGS			= (@CFLAGS@)
+#**	CFLAGS_DEBUG		= (@CFLAGS_DEBUG@)
+#**	CFLAGS_OPTIMIZE		= (@CFLAGS_OPTIMIZE@)
+#**	CFLAGS_WARNING		= (@CFLAGS_WARNING@)
+#**	CPP			= (@CPP@)
+#**	CPPFLAGS		= (@CPPFLAGS@)
+#**	DEFS			= (@DEFS@)
+#**	LDFLAGS			= (@LDFLAGS@)
+#**	LDFLAGS_DEFAULT		= (@LDFLAGS_DEFAULT@)
+#**	LIBS			= (@LIBS@)
+#**	MAKE_LIB		= (@MAKE_LIB@)
+#**	MAKE_SHARED_LIB		= (@MAKE_SHARED_LIB@)
+#**	MAKE_STATIC_LIB		= (@MAKE_STATIC_LIB@)
+#**	MAKE_STUB_LIB		= (@MAKE_STUB_LIB@)
+#**	MATH_LIBS		= (@MATH_LIBS@)
+#**	OBJEXT			= (@OBJEXT@)
+#**	SHLIB_CFLAGS		= (@SHLIB_CFLAGS@)
+#**	SHLIB_LD		= (@SHLIB_LD@)
+#**	SHLIB_LD_LIBS		= (@SHLIB_LD_LIBS@)
+#**	SHLIB_SUFFIX		= (@SHLIB_SUFFIX@)
+#**	STLIB_LD		= (@STLIB_LD@)
+#**	TCL_EXTRA_CFLAGS	= (@TCL_EXTRA_CFLAGS@)
+#**	TCL_INCLUDES		= (@TCL_INCLUDES@)
+#**	TCL_LD_FLAGS		= (@TCL_LD_FLAGS@)
+#**	TCL_LIBS		= (@TCL_LIBS@)
+#**	TCL_SHLIB_LD_LIBS	= (@TCL_SHLIB_LD_LIBS@)
+#**	TCL_THREADS		= (@TCL_THREADS@)
+
+#	AR			= (@AR@)
+#	CELIB_DIR		= (@CELIB_DIR@)
+#	CFLAGS_DEFAULT		= (@CFLAGS_DEFAULT@)
+#	CLEANFILES		= (@CLEANFILES@)
+#	CYGPATH			= (@CYGPATH@)
+#	ECHO_C			= (@ECHO_C@)
+#	ECHO_N			= (@ECHO_N@)
+#	ECHO_T			= (@ECHO_T@)
+#	EGREP			= (@EGREP@)
+#	EXEEXT			= (@EXEEXT@)
+#	GREP			= (@GREP@)
+#	INSTALL_DATA		= (@INSTALL_DATA@)
+#	INSTALL_PROGRAM		= (@INSTALL_PROGRAM@)
+#	INSTALL_SCRIPT		= (@INSTALL_SCRIPT@)
+#	LD_LIBRARY_PATH_VAR	= (@LD_LIBRARY_PATH_VAR@)
+#	LIBOBJS			= (@LIBOBJS@)
+#	LTLIBOBJS		= (@LTLIBOBJS@)
+#	PACKAGE_BUGREPORT	= (@PACKAGE_BUGREPORT@)
+#	PACKAGE_NAME		= (@PACKAGE_NAME@)
+#	PACKAGE_STRING		= (@PACKAGE_STRING@)
+#	PACKAGE_TARNAME		= (@PACKAGE_TARNAME@)
+#	PACKAGE_VERSION		= (@PACKAGE_VERSION@)
+#	PATH_SEPARATOR		= (@PATH_SEPARATOR@)
+#	PKG_CFLAGS		= (@PKG_CFLAGS@)
+#	PKG_HEADERS		= (@PKG_HEADERS@)
+#	PKG_INCLUDES		= (@PKG_INCLUDES@)
+#	PKG_LIBS		= (@PKG_LIBS@)
+#	PKG_LIB_FILE		= (@PKG_LIB_FILE@)
+#	PKG_OBJECTS		= (@PKG_OBJECTS@)
+#	PKG_SOURCES		= (@PKG_SOURCES@)
+#	PKG_STUB_LIB_FILE	= (@PKG_STUB_LIB_FILE@)
+#	PKG_STUB_OBJECTS	= (@PKG_STUB_OBJECTS@)
+#	PKG_STUB_SOURCES	= (@PKG_STUB_SOURCES@)
+#	PKG_TCL_SOURCES		= (@PKG_TCL_SOURCES@)
+#	RANLIB			= (@RANLIB@)
+#	RANLIB_STUB		= (@RANLIB_STUB@)
+#	SET_MAKE		= (@SET_MAKE@)
+#	SHARED_BUILD		= (@SHARED_BUILD@)
+#	SHELL			= (@SHELL@)
+#	TCLSH_PROG		= (@TCLSH_PROG@)
+#	TCL_BIN_DIR		= (@TCL_BIN_DIR@)
+#	TCL_DBGX		= (@TCL_DBGX@)
+#	TCL_DEFS		= (@TCL_DEFS@)
+#	TCL_LIB_FILE		= (@TCL_LIB_FILE@)
+#	TCL_LIB_FLAG		= (@TCL_LIB_FLAG@)
+#	TCL_LIB_SPEC		= (@TCL_LIB_SPEC@)
+#	TCL_PATCH_LEVEL		= (@TCL_PATCH_LEVEL@)
+#	TCL_SRC_DIR		= (@TCL_SRC_DIR@)
+#	TCL_STUB_LIB_FILE	= (@TCL_STUB_LIB_FILE@)
+#	TCL_STUB_LIB_FLAG	= (@TCL_STUB_LIB_FLAG@)
+#	TCL_STUB_LIB_SPEC	= (@TCL_STUB_LIB_SPEC@)
+#	TCL_VERSION		= (@TCL_VERSION@)
+#	VC_MANIFEST_EMBED_DLL	= (@VC_MANIFEST_EMBED_DLL@)
+#	VC_MANIFEST_EMBED_EXE	= (@VC_MANIFEST_EMBED_EXE@)
+
+#	ac_ct_CC		= (@ac_ct_CC@)
+#	bindir			= (@bindir@)
+#	build_alias		= (@build_alias@)
+#	datadir			= (@datadir@)
+#	datarootdir		= (@datarootdir@)
+#	docdir			= (@docdir@)
+#	dvidir			= (@dvidir@)
+#	exec_prefix		= (@exec_prefix@)
+#	host_alias		= (@host_alias@)
+#	htmldir			= (@htmldir@)
+#	includedir		= (@includedir@)
+#	infodir			= (@infodir@)
+#	libdir			= (@libdir@)
+#	libexecdir		= (@libexecdir@)
+#	localedir		= (@localedir@)
+#	localstatedir		= (@localstatedir@)
+#	mandir			= (@mandir@)
+#	oldincludedir		= (@oldincludedir@)
+#	pdfdir			= (@pdfdir@)
+#	prefix			= (@prefix@)
+#	program_transform_name	= (@program_transform_name@)
+#	psdir			= (@psdir@)
+#	sbindir			= (@sbindir@)
+#	sharedstatedir		= (@sharedstatedir@)
+#	sysconfdir		= (@sysconfdir@)
+#	target_alias		= (@target_alias@)
+
+# # ## ### ##### ######## ############# #####################

src/tclkit86bi.vfs/lib/critcl-app3.2/tea/Makefile.in

@@ -0,0 +1,145 @@
+# Makefile.in --
+#
+#	This file is a Makefile for "@@PNAME@@ @@PMAJORV@@.@@PMINORV@@". If this
+#	is "Makefile.in" then it is a template for a Makefile;  to generate 
+#	the actual Makefile, run "./configure", which is a configuration script
+#	generated by the "autoconf" program (constructs like "@foo@" will get
+#	replaced in the actual Makefile.
+#
+# Copyright (c) @@YEAR@@ @@PORG@@
+#
+# Generated by @@CRITCL@@
+# At           @@NOW@@
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+#========================================================================
+# Nothing of the variables below this line need to be changed.  Please
+# check the TARGETS section below to make sure the make targets are
+# correct.
+#========================================================================
+
+SHELL		= @SHELL@
+
+srcdir		= @srcdir@
+top_srcdir	= @top_srcdir@
+prefix		= @prefix@
+exec_prefix	= @exec_prefix@
+libdir		= @libdir@
+mandir		= @mandir@
+bindir		= @bindir@
+
+sbindir		= @sbindir@
+libexecdir	= @libexecdir@
+datarootdir	= @datarootdir@
+datadir		= @datadir@
+sysconfdir	= @sysconfdir@
+sharedir	= @sharedstatedir@
+statedir	= @localstatedir@
+includedir	= @includedir@
+oldincludedir	= @oldincludedir@
+
+DESTDIR		=
+pkglibdir	= $(libdir)/@PACKAGE_NAME@@PACKAGE_VERSION@
+top_builddir	= .
+
+PACKAGE = @PACKAGE_NAME@
+VERSION = @PACKAGE_VERSION@
+CYGPATH = @CYGPATH@
+
+TCLSH_PROG = @TCLSH_PROG@
+CRITCL     = `$(CYGPATH) $(srcdir)/critcl/main.tcl`
+
+CONFIG_CLEAN_FILES =
+@@API@@
+@@UCONFIG@@
+#========================================================================
+# PKG_TCL_SOURCES identifies Tcl runtime files that are associated with
+# this package that need to be installed, if any.
+#========================================================================
+
+PKG_TCL_SOURCES = @@PFILES@@
+
+#========================================================================
+# Start of user-definable TARGETS section
+#========================================================================
+
+all:
+	@echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+	@echo Please run '"make install"' to build and install the package.
+	@echo Critcl has no separate build-step.
+
+doc:
+	@echo No documentation to build.
+
+install:
+	@echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
+	cat $(top_builddir)/Config | grep -v '^#' ; \
+	echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
+	rm -rf $(top_builddir)/results-tea ; \
+	$(TCLSH_PROG) $(CRITCL) \
+		-I $(prefix)/include \
+		-I $(exec_prefix)/include \
+		-I $(includedir)@@APIUSE@@ \
+		@@UCONFIGUSE@@ \
+		-keep       -cache  $(top_builddir)/results-tea \
+		-target TEA -config $(top_builddir)/Config \
+		-libdir     $(DESTDIR)$(libdir) \
+		-includedir $(DESTDIR)$(includedir) \
+		-pkg $(PACKAGE)$(VERSION) \
+		$(PKG_TCL_SOURCES) ; \
+	echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
+	cat $(top_builddir)/results-tea/*.log
+	echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
+
+install-auto: show-auto
+	@rm -rf $(top_builddir)/results-auto ; \
+	$(TCLSH_PROG) $(CRITCL) \
+		-I $(prefix)/include \
+		-I $(exec_prefix)/include \
+		-I $(includedir)@@APIUSE@@ \
+		@@UCONFIGUSE@@ \
+		-keep -cache $(top_builddir)/results-auto \
+		-libdir     $(DESTDIR)$(libdir) \
+		-includedir $(DESTDIR)$(includedir) \
+		-pkg $(PACKAGE)$(VERSION) \
+		$(PKG_TCL_SOURCES) ; \
+	echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
+	cat $(top_builddir)/results-auto/*.log
+	echo %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ; \
+
+install-doc:
+	@echo No documentation to install.
+
+show:
+	@$(TCLSH_PROG) $(CRITCL) \
+		-keep -cache $(top_builddir)/results-tea \
+		-target TEA -config $(top_builddir)/Config \
+		-libdir $(DESTDIR)$(libdir) \
+		-pkg -show
+
+show-auto:
+	@$(TCLSH_PROG) $(CRITCL) \
+		-keep -cache $(top_builddir)/results-auto \
+		-libdir $(DESTDIR)$(libdir) \
+		-pkg -show
+
+clean:
+	rm -rf doc *-doc
+
+distclean: clean
+	-rm -f Makefile $(CONFIG_CLEAN_FILES)
+	-rm -f config.cache config.log stamp-h stamp-h[0-9]*
+	-rm -f config.status
+
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+	cd $(top_builddir) \
+	  && CONFIG_FILES=$@ CONFIG_HEADERS= $(SHELL) ./config.status
+
+
+.PHONY: all binaries clean depend distclean doc install installdirs libraries test
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:

src/tclkit86bi.vfs/lib/critcl-app3.2/tea/aclocal.m4

@@ -0,0 +1,180 @@
+#
+# Include the TEA standard macro set
+#
+
+builtin(include,tclconfig/tcl.m4)
+
+#
+# Add here whatever m4 macros you want to define for your package
+#
+
+#------------------------------------------------------------------------
+# CRITCL_TEA_PUBLIC_PACKAGE_HEADERS --
+#
+#	Locate the installed public FOO header files
+#
+# Arguments:
+#	Name of the package to search headers for.
+#
+# Requires:
+#	CYGPATH must be set
+#
+# Results:
+#
+#	Adds a --with-[$1]-include switch to configure.
+#	Result is cached.
+#
+#	Substs the following vars:
+#		CRITCL_API_$1_INCLUDE
+#------------------------------------------------------------------------
+
+AC_DEFUN([CRITCL_TEA_PUBLIC_PACKAGE_HEADERS],[
+    # CRITCL_TEA_PUBLIC_PACKAGE_HEADERS: $1
+    AC_MSG_CHECKING([for $1 public headers])
+    AC_ARG_WITH([$1-include], [  --with-$1-include       directory containing the public $1 header files], [with_$1_include=${withval}])
+    AC_CACHE_VAL(ac_cv_c_$1_header, [
+	# Use the value from --with-$1-include, if it was given
+
+	if test x"[$]{with_$1_include}" != x ; then
+	    if test -f "[$]{with_$1_include}/$1Decls.h" ; then
+		ac_cv_c_$1_header=[$]{with_$1_include}
+	    else
+		AC_MSG_ERROR([[$]{with_$1_include} directory does not contain $1Decls.h])
+	    fi
+	else
+	    list=""
+	    if test "`uname -s`" = "Darwin"; then
+		# If $1 was built as a framework, attempt to use
+		# the framework's Headers directory
+		case [$]{$1_DEFS} in
+		    *$1_FRAMEWORK*)
+			list="`ls -d [$]{$1_BIN_DIR}/Headers 2>/dev/null`"
+			;;
+		esac
+	    fi
+
+	    # Check order: pkg --prefix location, Tcl's --prefix location,
+	    # relative to directory of $1Config.sh.
+
+	    eval "temp_includedir=[$]{includedir}"
+	    list="[$]list \
+		`ls -d [$]{temp_includedir}        2>/dev/null` \
+		`ls -d [$]{$1_PREFIX}/include     2>/dev/null` \
+		`ls -d [$]{$1_BIN_DIR}/../include 2>/dev/null` \
+		`ls -d ${TCL_PREFIX}/include     2>/dev/null` \
+		`ls -d ${TCL_BIN_DIR}/../include 2>/dev/null`"
+
+	    if test "[$]{TEA_PLATFORM}" != "windows" -o "[$]GCC" = "yes"; then
+		list="[$]list /usr/local/include /usr/include"
+		if test x"[$]{$1_INCLUDE_SPEC}" != x ; then
+		    d=`echo "[$]{$1_INCLUDE_SPEC}" | sed -e 's/^-I//'`
+		    list="[$]list `ls -d ${d} 2>/dev/null`"
+		fi
+	    fi
+	    for i in [$]list ; do
+		if test -f "[$]i/$1/$1Decls.h" ; then
+		    ac_cv_c_$1_header=[$]i
+		    break
+		fi
+	    done
+	fi
+    ])
+
+    # Print a message based on how we determined the include path
+    if test x"[$]{ac_cv_c_$1_header}" = x ; then
+	AC_MSG_ERROR([$1Decls.h not found.  Please specify its location with --with-$1-include])
+    else
+	AC_MSG_RESULT([[$]{ac_cv_c_$1_header}])
+    fi
+
+    # Convert to a native path and substitute into the transfer variable.
+    # NOTE: Anything going into actual TEA would have to use A TEA_xx
+    # transfer variable, instead of critcl.
+    INCLUDE_DIR_NATIVE=`[$]{CYGPATH} [$]{ac_cv_c_$1_header}`
+    CRITCL_API_$1_INCLUDE="\"[$]{INCLUDE_DIR_NATIVE}\""
+    AC_SUBST([CRITCL_API_$1_INCLUDE])
+])
+
+#------------------------------------------------------------------------
+# CRITCL_TEA_WITH_CONFIG --
+#
+#	Declare a --with-FOO option, with default and legal values.
+#
+# Arguments:
+#	Name of the option.
+#	List of legal values.
+#	Default value.
+#	Option description.
+#
+# Requires:
+# Results:
+#	Adds a --with-[$1] switch to configure.
+#
+#	Substs the following vars:
+#		CRITCL_UCONFIG_$1
+#------------------------------------------------------------------------
+
+AC_DEFUN([CRITCL_TEA_WITH_CONFIG],[
+    # CRITCL_TEA_WITH_CONFIG: $1
+    AC_ARG_WITH([$1],
+	AC_HELP_STRING([--with-$1],
+		       [$4]),
+	[with_uc_$1=${withval}])
+
+    # Use default if user did not specify anything.
+    if test x"[$]{with_uc_$1}" = x ; then
+	with_uc_$1="$3"
+    fi
+
+    AC_MSG_CHECKING([Validating $1])
+    tcl_ok=no
+    for x in $2
+    do
+        if test "[$]x" = "[$]with_uc_$1" ; then
+	    tcl_ok=yes
+	    break
+	fi
+    done
+    if test "[$]tcl_ok" = "no" ; then
+	AC_MSG_ERROR([Illegal value [$]with_uc_$1, expected one of: $2])
+    else
+	AC_MSG_RESULT([[$]with_uc_$1])
+    fi
+
+    CRITCL_UCONFIG_$1="-with-$1 \"[$]with_uc_$1\""
+    AC_SUBST([CRITCL_UCONFIG_$1])
+])
+
+#------------------------------------------------------------------------
+# CRITCL_TEA_BOOL_CONFIG --
+#
+#	Declare a --disable/enable-FOO option, with default.
+#
+# Arguments:
+#	Name of the option.
+#	Default value.
+#	Option description.
+#
+# Requires:
+# Results:
+#	Adds a --enable-[$1] switch to configure.
+#
+#	Substs the following vars:
+#		CRITCL_UCONFIG_$1
+#------------------------------------------------------------------------
+
+AC_DEFUN([CRITCL_TEA_BOOL_CONFIG],[
+    # CRITCL_TEA_BOOL_CONFIG: $1
+    AC_ARG_ENABLE([$1],
+	AC_HELP_STRING([--enable-$1],[$3]),
+	[bool_uc_$1=${enableval}]
+	[bool_uc_$1="$2"])
+
+    if test "bool_uc_$1" = "yes" ; then
+    	CRITCL_UCONFIG_$1="-enable $1"
+    else
+    	CRITCL_UCONFIG_$1="-disable $1"
+    fi
+
+    AC_SUBST([CRITCL_UCONFIG_$1])
+])

src/tclkit86bi.vfs/lib/critcl-app3.2/tea/configure.in

@@ -0,0 +1,151 @@
+# Configure for
+# 	@@PNAME@@ @@PMAJORV@@.@@PMINORV@@
+#
+# Copyright (c) @@YEAR@@ @@PORG@@
+#
+# Generated by @@CRITCL@@
+# At           @@NOW@@
+
+AC_INIT([@@PNAME@@],[@@PMAJORV@@.@@PMINORV@@])
+
+TEA_INIT([3.9])
+
+AC_CONFIG_AUX_DIR(tclconfig)
+
+#--------------------------------------------------------------------
+# Configure script for package '@@PNAME@@'.
+# TEA compliant.
+#--------------------------------------------------------------------
+
+#--------------------------------------------------------------------
+# Load the tclConfig.sh file
+#--------------------------------------------------------------------
+
+TEA_PATH_TCLCONFIG
+TEA_LOAD_TCLCONFIG
+
+#-----------------------------------------------------------------------
+## Std TEA setup
+
+TEA_PREFIX
+TEA_SETUP_COMPILER
+TEA_PUBLIC_TCL_HEADERS
+#TEA_PRIVATE_TCL_HEADERS
+TEA_ENABLE_THREADS
+TEA_ENABLE_SHARED
+TEA_CONFIG_CFLAGS
+TEA_ENABLE_SYMBOLS
+AC_DEFINE(USE_TCL_STUBS)
+TEA_MAKE_LIB
+TEA_PROG_TCLSH
+@@API@@
+@@UCONFIG@@
+#-----------------------------------------------------------------------
+## Convert the TEA settings determined by the macros in the last
+## section into something critcl can use throughts configuration.
+
+AC_MSG_RESULT([critcl config: derived from core TEA])
+
+#AC_MSG_RESULT([critcl config: CC............. ${CC}])
+#AC_MSG_RESULT([critcl config: CFLAGS......... ${CFLAGS}])
+#AC_MSG_RESULT([critcl config: SHLIB_LD....... ${SHLIB_LD}])
+#AC_MSG_RESULT([critcl config: LIBS........... ${LIBS}|
+#AC_MSG_RESULT([critcl config: MATH_LIBS...... ${MATH_LIBS}])
+#AC_MSG_RESULT([critcl config: CFLAGS_DEFAULT. ${CFLAGS_DEFAULT}])
+#AC_MSG_RESULT([critcl config: CFLAGS_WARNING. ${CFLAGS_WARNING}])
+#AC_MSG_RESULT([critcl config: SHLIB_CFLAGS... ${SHLIB_CFLAGS}])
+#AC_MSG_RESULT([critcl config: LDFLAGS_DEFAULT ${LDFLAGS_DEFAULT}])
+
+#-----------------------------------------------------------------------
+## 1. Basic/foundational translation.
+
+CRITCL_CC="$(eval echo ${CC} -c ${CFLAGS})"
+CRITCL_VERSION="${CC} -v"
+CRITCL_LINK="$(eval echo $(eval echo ${SHLIB_LD} ${LIBS} ${MATH_LIBS}))"
+CRITCL_PLATFORM="$(${TCLSH_PROG} ${srcdir}/critcl/main.tcl -showtarget)"
+CRITCL_LD_DBG=""
+CRITCL_LD_REL=""
+CRITCL_CC_OUTPUT="-o [[list \$outfile]]"
+CRITCL_LD_OUTPUT=""
+
+if test "${GCC}" = "yes"
+then
+   CRITCL_CPP_DEFINE="${CPP} -dM"
+else
+   CRITCL_CPP_DEFINE="${CPP}"
+
+   if test "${TEA_PLATFORM}" = "windows"
+   then
+      # windows, no gcc => msvc
+      CRITCL_CC_OUTPUT="[[list -Fo\$outfile]]"
+      CRITCL_LD_OUTPUT="-dll [[list -out:\$outfile]]"
+      CRITCL_LD_DBG="-debug:full -debugtype:cv -verbose:lib"
+      CRITCL_LD_REL="-release -opt:ref -opt:icf,3 -ws:aggressive -verbose:lib"
+      if test "$do64bit" = "no" ; then
+          # 32bit
+	  CRITCL_LD_DBG="$CRITCL_LD_DBG -nodefaultlib:libc"
+      fi
+   fi
+fi
+CRITCL_CPP_ENUM="${CPP}"
+
+#-----------------------------------------------------------------------
+## 2. Fine tuning the commands, this now is platform specific.
+
+case $(uname -s) in
+Darwin*)
+	AC_MSG_RESULT([critcl config: darwin specific tune-up])
+
+	# - Critcl, due to essentially generating its private
+	#   lib{tcl,tk}stub.a does generate common symbols for the
+	#   stubs tables. Use of -fno-common then prevents linking the
+	#   object files.
+	#
+	# - A version 0.0 as pulled from TEA package version is not
+	#   liked by the Darwin gcc either (Example: crimp).
+
+	CRITCL_CC="$(echo   "$CRITCL_CC"  |sed -e 's,-fno-common,,g')"
+	CRITCL_LINK="$(echo "$CRITCL_LINK"|sed -e 's,-fno-common,,g')"
+	CRITCL_LINK="$(echo "$CRITCL_LINK"|sed -e 's,-current_version 0\.0,,g')"
+	CRITCL_LINK="$(echo "$CRITCL_LINK"|sed -e 's,-compatibility_version 0\.0,,g')"
+	;;
+*)
+	;;
+esac
+
+#-----------------------------------------------------------------------
+## Conversion results
+
+AC_MSG_RESULT([critcl config: platform.......... $CRITCL_PLATFORM])
+AC_MSG_RESULT([critcl config: compile........... $CRITCL_CC])
+AC_MSG_RESULT([critcl config: link.............. $CRITCL_LINK])
+AC_MSG_RESULT([critcl config: cpp define........ $CRITCL_CPP_DEFINE])
+AC_MSG_RESULT([critcl config: cpp enum.......... $CRITCL_CPP_ENUM])
+AC_MSG_RESULT([critcl config: version inquiry... $CRITCL_VERSION])
+AC_MSG_RESULT([critcl config: cc output......... $CRITCL_CC_OUTPUT])
+AC_MSG_RESULT([critcl config: ld output......... $CRITCL_LD_OUTPUT])
+AC_MSG_RESULT([critcl config: ld debug.......... $CRITCL_LD_DBG])
+AC_MSG_RESULT([critcl config: ld release........ $CRITCL_LD_REL])
+
+#-----------------------------------------------------------------------
+
+AC_SUBST(CRITCL_CC)
+AC_SUBST(CRITCL_VERSION)
+AC_SUBST(CRITCL_LINK)
+AC_SUBST(CRITCL_PLATFORM)
+AC_SUBST(CRITCL_CPP_DEFINE)
+AC_SUBST(CRITCL_CPP_ENUM)
+AC_SUBST(CRITCL_CC_OUTPUT)
+AC_SUBST(CRITCL_LD_OUTPUT)
+AC_SUBST(CRITCL_LD_DBG)
+AC_SUBST(CRITCL_LD_REL)
+#AC_SUBST(CRITCL_)
+#AC_SUBST()
+
+#--------------------------------------------------------------------
+# Finally, substitute all of the various values into the Makefile.
+# You may alternatively have a special pkgIndex.tcl.in or other files
+# which require substituting th AC variables in.  Include these here.
+#--------------------------------------------------------------------
+
+AC_OUTPUT([Makefile Config])

src/tclkit86bi.vfs/lib/critcl-app3.2/tea/tclconfig/README.txt

@@ -0,0 +1,26 @@
+These files comprise the basic building blocks for a Tcl Extension
+Architecture (TEA) extension.  For more information on TEA see:
+
+	http://www.tcl.tk/doc/tea/
+
+This package is part of the Tcl project at SourceForge, and latest
+sources should be available there:
+
+	http://tcl.sourceforge.net/
+
+This package is a freely available open source package.  You can do
+virtually anything you like with it, such as modifying it, redistributing
+it, and selling it either in whole or in part.
+
+CONTENTS
+========
+The following is a short description of the files you will find in
+the sample extension.
+
+README.txt	This file
+
+install-sh	Program used for copying binaries and script files
+		to their install locations.
+
+tcl.m4		Collection of Tcl autoconf macros.  Included by a package's
+		aclocal.m4 to define TEA_* macros.

src/tclkit86bi.vfs/lib/critcl-app3.2/tea/tclconfig/install-sh

@@ -0,0 +1,119 @@
+#!/bin/sh
+
+#
+# install - install a program, script, or datafile
+# This comes from X11R5; it is not part of GNU.
+#
+# $XConsortium: install.sh,v 1.2 89/12/18 14:47:22 jim Exp $
+#
+# This script is compatible with the BSD install script, but was written
+# from scratch.
+#
+
+
+# set DOITPROG to echo to test this script
+
+# Don't use :- since 4.3BSD and earlier shells don't like it.
+doit="${DOITPROG-}"
+
+
+# put in absolute paths if you don't have them in your path; or use env. vars.
+
+mvprog="${MVPROG-mv}"
+cpprog="${CPPROG-cp}"
+chmodprog="${CHMODPROG-chmod}"
+chownprog="${CHOWNPROG-chown}"
+chgrpprog="${CHGRPPROG-chgrp}"
+stripprog="${STRIPPROG-strip}"
+rmprog="${RMPROG-rm}"
+
+instcmd="$mvprog"
+chmodcmd=""
+chowncmd=""
+chgrpcmd=""
+stripcmd=""
+rmcmd="$rmprog -f"
+mvcmd="$mvprog"
+src=""
+dst=""
+
+while [ x"$1" != x ]; do
+    case $1 in
+	-c) instcmd="$cpprog"
+	    shift
+	    continue;;
+
+	-m) chmodcmd="$chmodprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-o) chowncmd="$chownprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-g) chgrpcmd="$chgrpprog $2"
+	    shift
+	    shift
+	    continue;;
+
+	-s) stripcmd="$stripprog"
+	    shift
+	    continue;;
+
+	*)  if [ x"$src" = x ]
+	    then
+		src=$1
+	    else
+		dst=$1
+	    fi
+	    shift
+	    continue;;
+    esac
+done
+
+if [ x"$src" = x ]
+then
+	echo "install:  no input file specified"
+	exit 1
+fi
+
+if [ x"$dst" = x ]
+then
+	echo "install:  no destination specified"
+	exit 1
+fi
+
+
+# If destination is a directory, append the input filename; if your system
+# does not like double slashes in filenames, you may need to add some logic
+
+if [ -d $dst ]
+then
+	dst="$dst"/`basename $src`
+fi
+
+# Make a temp file name in the proper directory.
+
+dstdir=`dirname $dst`
+dsttmp=$dstdir/#inst.$$#
+
+# Move or copy the file name to the temp name
+
+$doit $instcmd $src $dsttmp
+
+# and set any options; do chmod last to preserve setuid bits
+
+if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; fi
+if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; fi
+if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; fi
+if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; fi
+
+# Now rename the file to the real destination.
+
+$doit $rmcmd $dst
+$doit $mvcmd $dsttmp $dst
+
+
+exit 0

src/tclkit86bi.vfs/lib/critcl-bitmap1.1/bitmap.tcl

@@ -0,0 +1,227 @@
+## -*- tcl -*-
+# # ## ### ##### ######## ############# #####################
+# Pragmas for MetaData Scanner.
+# n/a
+
+# CriTcl Utility Package for bitmap en- and decoder.
+# Based on i-assoc.
+
+package provide critcl::bitmap 1.1
+
+# # ## ### ##### ######## ############# #####################
+## Requirements.
+
+package require Tcl    8.6     ; # Min supported version.
+package require critcl 3.2
+package require critcl::iassoc
+
+namespace eval ::critcl::bitmap {}
+
+# # ## ### ##### ######## ############# #####################
+## Implementation -- API: Embed C Code
+
+proc critcl::bitmap::def {name dict {exclusions {}}} {
+    # dict: Tcl symbolic name -> (C bit-mask (1))
+    #
+    # (Ad 1) Can be numeric, or symbolic, as long as it is a C int
+    #        expression in the end.
+    #
+    # (Ad exclusions)
+    #        Excluded bit-masks cannot be converted back to Tcl
+    #        symbols. These are usually masks with multiple bits
+    #        set. Conversion back delivers the individual elements
+    #        instead of the combined mask.
+    #
+    #        If no exclusions are specified the generated code is
+    #        simpler, i.e. not containing anything for dealing with
+    #        exclusions at runtime.
+
+    # For the C level opt array we want the elements sorted alphabetically.
+    set symbols [lsort -dict [dict keys $dict]]
+    set i 0
+    foreach s $symbols {
+	set id($s) $i
+	incr i
+    }
+    set last $i
+
+    set hasexcl [llength $exclusions]
+    set excl {}
+    foreach e $exclusions {
+	dict set excl $e .
+    }
+
+    dict for {sym mask} $dict {
+	set receivable [expr {![dict exists $excl $mask]}]
+
+	set map [list @ID@ $id($sym) @SYM@ $sym @MASK@ $mask @RECV@ $receivable]
+
+	if {$hasexcl} {
+	    append init \n[critcl::at::here!][string map $map {
+		data->c    [@ID@] = "@SYM@";
+		data->mask [@ID@] = @MASK@;
+		data->recv [@ID@] = @RECV@;
+		data->tcl  [@ID@] = Tcl_NewStringObj ("@SYM@", -1);
+		Tcl_IncrRefCount (data->tcl [@ID@]);
+	    }]
+	} else {
+	    append init \n[critcl::at::here!][string map $map {
+		data->c    [@ID@] = "@SYM@";
+		data->mask [@ID@] = @MASK@;
+		data->tcl  [@ID@] = Tcl_NewStringObj ("@SYM@", -1);
+		Tcl_IncrRefCount (data->tcl [@ID@]);
+	    }]
+	}
+
+	append final \n[critcl::at::here!][string map $map {
+	    Tcl_DecrRefCount (data->tcl [@ID@]);
+	}]
+    }
+    append init \n "    data->c \[$last\] = NULL;"
+
+    lappend map @NAME@  $name
+    lappend map @UNAME@ [string toupper $name]
+    lappend map @LAST@  $last
+
+    # I. Generate a header file for inclusion by other parts of the
+    #    package, i.e. csources. Include the header here as well, for
+    #    the following blocks of code.
+    #
+    #    Declaration of the en- and decoder functions.
+
+    critcl::include [critcl::make ${name}.h \n[critcl::at::here!][string map $map {
+	#ifndef @NAME@_HEADER
+	#define @NAME@_HEADER
+
+	/* Encode a flag list into the corresponding bitset */
+	extern int
+	@NAME@_encode (Tcl_Interp* interp,
+		       Tcl_Obj*    flags,
+		       int*        result);
+
+	/* Decode a bitset into the corresponding flag list */
+	extern Tcl_Obj*
+	@NAME@_decode (Tcl_Interp* interp,
+		       int         mask);
+
+	#endif
+    }]]
+
+    # II: Generate the interp association holding the various
+    #     conversion maps.
+
+    if {$hasexcl} {
+	critcl::iassoc def ${name}_iassoc {} \n[critcl::at::here!][string map $map {
+	    const char*    c    [@LAST@+1]; /* Bit name, C string */
+	    Tcl_Obj*       tcl  [@LAST@];   /* Bit name, Tcl_Obj*, sharable */
+	    int            mask [@LAST@];   /* Bit mask */
+	    int            recv [@LAST@];   /* Flag, true for receivable event */
+	}] $init $final
+    } else {
+	critcl::iassoc def ${name}_iassoc {} \n[critcl::at::here!][string map $map {
+	    const char*    c    [@LAST@+1]; /* Bit name, C string */
+	    Tcl_Obj*       tcl  [@LAST@];   /* Bit name, Tcl_Obj*, sharable */
+	    int            mask [@LAST@];   /* Bit mask */
+	}] $init $final
+    }
+
+    # III: Generate encoder function: Conversion of list of flag names
+    #      into corresponding bitset.
+
+    critcl::ccode \n[critcl::at::here!][string map $map {
+	int
+	@NAME@_encode (Tcl_Interp* interp,
+		       Tcl_Obj*    flags,
+		       int*        result)
+	{
+	    @NAME@_iassoc_data context = @NAME@_iassoc (interp);
+	    int mask, lc, i, id;
+	    Tcl_Obj** lv;
+
+	    if (Tcl_ListObjGetElements (interp, flags, &lc, &lv) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+
+	    mask = 0;
+	    for (i = 0; i < lc; i++)  {
+		if (Tcl_GetIndexFromObj (interp, lv[i], context->c, "@NAME@", 0,
+					 &id) != TCL_OK) {
+		    Tcl_SetErrorCode (interp, "@UNAME@", "FLAG", NULL);
+		    return TCL_ERROR;
+		}
+		mask |= context->mask [id];
+	    }
+
+	    *result = mask;
+	    return TCL_OK;
+	}
+    }]
+
+    # IV: Generate decoder function: Convert bitset into the
+    #     corresponding list of flag names.
+
+    if {$hasexcl} {
+	critcl::ccode \n[critcl::at::here!][string map $map {
+	    Tcl_Obj*
+	    @NAME@_decode (Tcl_Interp* interp, int mask)
+	    {
+		int i;
+		@NAME@_iassoc_data context = @NAME@_iassoc (interp);
+		Tcl_Obj*           res     = Tcl_NewListObj (0, NULL);
+
+		for (i = 0; i < @LAST@; i++)  {
+		    if (!context->recv[i])          continue;
+		    if (!(mask & context->mask[i])) continue;
+		    (void) Tcl_ListObjAppendElement (interp, res, context->tcl [i]);
+		}
+		return res;
+	    }
+	}]
+    } else {
+	critcl::ccode \n[critcl::at::here!][string map $map {
+	    Tcl_Obj*
+	    @NAME@_decode (Tcl_Interp* interp, int mask)
+	    {
+		int i;
+		@NAME@_iassoc_data context = @NAME@_iassoc (interp);
+		Tcl_Obj*           res     = Tcl_NewListObj (0, NULL);
+
+		for (i = 0; i < @LAST@; i++)  {
+		    if (!(mask & context->mask[i])) continue;
+		    (void) Tcl_ListObjAppendElement (interp, res, context->tcl [i]);
+		}
+		return res;
+	    }
+	}]
+    }
+
+    # V. Define convenient argument- and result-type definitions
+    #    wrapping the de- and encoder functions for use by cprocs.
+
+    critcl::argtype $name \n[critcl::at::here!][string map $map {
+	if (@NAME@_encode (interp, @@, &@A) != TCL_OK) return TCL_ERROR;
+    }] int int
+
+    critcl::resulttype $name \n[critcl::at::here!][string map $map {
+	/* @NAME@_decode result is 0-refcount */
+	Tcl_SetObjResult (interp, @NAME@_decode (interp, rv));
+	return TCL_OK;
+    }] int
+}
+
+# # ## ### ##### ######## ############# #####################
+## Export API
+
+namespace eval ::critcl::bitmap {
+    namespace export def
+    catch { namespace ensemble create }
+}
+
+namespace eval ::critcl {
+    namespace export bitmap
+    catch { namespace ensemble create }
+}
+
+# # ## ### ##### ######## ############# #####################
+## Ready
+return