vfs update

src/vfs/_config/punk_main.tcl

@@ -149,6 +149,11 @@ apply { args {
     set topdir [file dirname $normscript]
     set found_starkit_tcl 0
     set possible_lib_vfs_folders [glob -nocomplain -dir [file join $topdir lib] -type d vfs*]
+    if {$has_zipfs_attached} {
+        if {[file exists [zipfs root]/app/tcl_library]} {
+            lappend possible_lib_vfs_folders {*}[glob -nocomplain -dir [zipfs root]/app/tcl_library -type d vfs*]
+        }
+    }
     foreach test_folder $possible_lib_vfs_folders {
         #e.g <name_of_exe>/lib/vfs1.4.1
         #we don't expect multiple vfs* folders - but we will process any found and load the pkgIndex.tcl from these folders.
@@ -178,6 +183,7 @@ apply { args {
         #puts stderr [join [package names] \n]
         set original_packages [package names]
 
+        #This is what we were trying to avoid - a package require causing a scan of ::auto_path and tcl::tm::list
         if {![catch {package require starkit}]} {
             #known side-effects of starkit::startup
             #sets the ::starkit::mode variable to the way in which it was launched. One of: {starpack starkit unwrapped tclhttpd plugin service sourced}
@@ -185,9 +191,11 @@ apply { args {
             #if mode not starpack, then:
             #   - adds $::starkit::topdir/lib to the auto_path if not already present
             #
-            #In this context (vfs attached to tcl kit executable - we expect the launch mode to be 'starkit'
+            #In the context of a metakit vfs attached to tcl kit executable - we expect the launch mode to be 'starkit'
             set starkit_startmode [starkit::startup]
-            puts stderr "STARKIT MODE: $starkit_startmode"
+            #However - we may also get here for a zipfs enabled tcl with a zifps vfs attached - but which has vlerq, starkit and vfs libraries available,
+            #in which case the mode seems to be reported as 'unwrapped'
+            #puts stderr "STARKIT MODE: $starkit_startmode"
         }
         #puts "main.tcl 2)--> package name count: [llength [package names]]"
         foreach pkg [package names] {
@@ -801,53 +809,43 @@ apply { args {
         #puts stderr "main.tcl tcl::tm::list:[tcl::tm::list]"
     }
 
-    if {1 || $has_zipfs_attached} {
-        #load libunknown without triggering the existing package unknown
 
-        #maint: also in punk::repl package
-        #--------------------------------------------------------
-        set libunks [list]
-        foreach tm_path [tcl::tm::list] {
-            set punkdir [file join $tm_path punk]
-            if {![file exists $punkdir]} {continue}
-            lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm]
-        }
-        set libunknown ""
-        set libunknown_version_sofar ""
-        foreach lib $libunks {
-            #expecting to be of form libunknown-<tclversion>.tm
-            set vtail [lindex [split [file tail $lib] -] 1]
-            set thisver [file rootname $vtail] ;#file rootname x.y.z.tm
-            if {$libunknown_version_sofar eq ""} {
+
+    #--------------------------------------------------------
+    #load libunknown without triggering the existing package unknown
+    #maint: also in punk::repl package
+    #--------------------------------------------------------
+    set libunks [list]
+    foreach tm_path [tcl::tm::list] {
+        set punkdir [file join $tm_path punk]
+        if {![file exists $punkdir]} {continue}
+        lappend libunks {*}[glob -nocomplain -dir $punkdir -type f libunknown-*.tm]
+    }
+    set libunknown ""
+    set libunknown_version_sofar ""
+    foreach lib $libunks {
+        #expecting to be of form libunknown-<tclversion>.tm
+        set vtail [lindex [split [file tail $lib] -] 1]
+        set thisver [file rootname $vtail] ;#file rootname x.y.z.tm
+        if {$libunknown_version_sofar eq ""} {
+            set libunknown_version_sofar $thisver
+            set libunknown $lib
+        } else {
+            if {[package vcompare $thisver $libunknown_version_sofar] == 1} {
                 set libunknown_version_sofar $thisver
                 set libunknown $lib
-            } else {
-                if {[package vcompare $thisver $libunknown_version_sofar] == 1} {
-                    set libunknown_version_sofar $thisver
-                    set libunknown $lib
-                }
             }
         }
-        if {$libunknown ne ""} {
-            source $libunknown
-            if {[catch {punk::libunknown::init -caller main.tcl} errM]} {
-                puts "error initialising punk::libunknown\n$errM"
-            }
+    }
+    if {$libunknown ne ""} {
+        source $libunknown
+        if {[catch {punk::libunknown::init -caller main.tcl} errM]} {
+            puts "error initialising punk::libunknown\n$errM"
         }
-        #--------------------------------------------------------
-
-
-        #set zr [::tcl::zipfs::root] ;#always ends with / ? - REVIEW
-        #if {[file join $zr app modules] in [tcl::tm::list]} {
-        #    #todo - better way to find latest version - without package require
-        #    set lib [file join $zr app modules punk libunknown.tm]
-        #    if {[file exists $lib]} {
-        #        source $lib
-        #        punk::libunknown::init
-        #        #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown}
-        #    }
-        #}
     }
+    #--------------------------------------------------------
+    #Now that new 'package unknown' mechanism is in place - we can use package require
+
 
     #assert arglist has had 'dev|os|os-dev etc' first arg removed if it was present.
     if {[llength $arglist] == 1 && [lindex $arglist 0] eq "tclsh"} {

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

@@ -49,16 +49,20 @@ repl::init -safe 0
 #flush stderr
 set replresult [repl::start stdin -title app-punk]
 
-catch {
-    puts "app-punk ifneeded: [package ifneeded app-punk 1.0]"
-}
+#catch {
+#    puts "app-punk ifneeded: [package ifneeded app-punk 1.0]"
+#}
+
 #review
 if {[string is integer -strict $replresult]} {
-    puts stdout "repl.tcl exiting with numeric code $replresult"
+    #puts stdout "repl.tcl exiting with numeric code $replresult"
     exit $replresult
 } else {
-    puts stdout "repl.tcl result $replresult"
-    flush stdout
+    if {$replresult ne ""} {
+        #puts stdout "repl.tcl result $replresult"
+        puts stdout $replresult
+        flush stdout
+    }
     exit 0
 }
 #puts "- repl app done -"

src/vfs/_vfscommon.vfs/lib/app-punkshell/punkshell.tcl

@@ -1,6 +1,7 @@
 package provide app-punkshell 1.0
 
 package require Thread
+package require punk::lib  ;#required for compat - lpop for some early Tcl 8.6 versions
 package require punk::args
 package require shellfilter
 package require punk::ansi

src/vfs/_vfscommon.vfs/modules/punk/args-0.2.tm

@@ -3036,8 +3036,11 @@ tcl::namespace::eval punk::args {
     #This mechanism gets less-than-useful results for oo methods
     #e.g {$obj}
     proc Get_caller {} {
+        set depth [info level]
+        set maxd [expr {min($depth,4)}]
+        set call_level [expr {-1 * $maxd}]
         #set call_level -3 ;#for get_dict call
-        set call_level -4
+        #set call_level -4
         set cmdinfo [tcl::dict::get [tcl::info::frame $call_level] cmd]
         #puts "-->$cmdinfo"
         #puts "-->[tcl::info::frame -3]"

src/vfs/_vfscommon.vfs/modules/punk/args/tclcore-0.1.0.tm

@@ -3498,7 +3498,7 @@ tcl::namespace::eval punk::args::tclcore {
                   example, in ${$B}-dictionary${$N} mode, bigBoy sorts between bigbang and bigboy,
                   and x10y sorts between x9y and x11y. Overrides the ${$B}-nocase${$N} option."
             -integer -type none -help\
-                "Convert list elements to integers and use integer comparsion."
+                "Convert list elements to integers and use integer comparison."
             -real -type none -help\
                 "Convert list elements to floating-point values and use floating comparison."
             -command -type string -help\

src/vfs/_vfscommon.vfs/modules/punk/console-0.1.1.tm

@@ -129,57 +129,362 @@ namespace eval punk::console {
         #e.g external utils system API's.
         namespace export *
     }
-    
+
     if {"windows" eq $::tcl_platform(platform)} {
         #accept args for all dummy/load functions so we don't have to match/update argument signatures here
+        set has_twapi [expr {! [catch {package require twapi}]}]
+
+        if {$has_twapi} {
+            #this is really enableAnsi *processing*
+            proc enableAnsi {} {
+                #output handle modes
+                #Enable virtual terminal processing (sometimes off in older windows terminals)
+                #ENABLE_PROCESSED_OUTPUT = 0x0001
+                #ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002
+                #ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
+                #DISABLE_NEWLINE_AUTO_RETURN = 0x0008
+                if {[catch {twapi::get_console_handle stdout} h_out]} {
+                    puts stderr "enableAnsi failed: twapi cannot get console handle for stdout"
+                    return
+                }
 
-        proc enableAnsi {args} {
-            #loopavoidancetoken (don't remove) 
-            internal::define_windows_procs
-            internal::abort_if_loop
-            tailcall enableAnsi {*}$args
-        }
-        #review what raw mode means with regard to a specific channel vs terminal as a whole
-        proc enableRaw {args} {
-            #loopavoidancetoken (don't remove) 
-            internal::define_windows_procs
-            internal::abort_if_loop
-            tailcall enableRaw {*}$args 
-        }
-        proc disableRaw {args} {
-            #loopavoidancetoken (don't remove) 
-            internal::define_windows_procs
-            internal::abort_if_loop
-            tailcall disableRaw {*}$args
-        }
-        proc enableVirtualTerminal {args} {
-            #loopavoidancetoken (don't remove) 
-            internal::define_windows_procs
-            internal::abort_if_loop
-            tailcall enableVirtualTerminal {*}$args
-        }
-        proc disableVirtualTerminal {args} {
-            #loopavoidancetoken (don't remove) 
-            internal::define_windows_procs
-            internal::abort_if_loop
-            tailcall disableVirtualTerminal {*}$args
-        }
-        set funcs [list disableAnsi enableProcessedInput disableProcessedInput]
-        foreach f $funcs {
-            proc $f {args} [string map [list %f% $f] {
-                set mybody [info body %f%]
-                internal::define_windows_procs
-                set newbody [info body %f%]
-                if {$newbody ne $mybody} {
-                    tailcall %f% {*}$args
+                set oldmode_out [twapi::GetConsoleMode $h_out]
+                set newmode_out [expr {$oldmode_out | 4}] ;#don't enable processed output too, even though it's required. keep symmetrical with disableAnsi?
+
+                twapi::SetConsoleMode $h_out $newmode_out
+
+                #what does window_input have to do with it??
+                #input handle modes
+                #ENABLE_PROCESSED_INPUT 0x0001  ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal
+                #ENABLE_LINE_INPUT 0x0002
+                #ENABLE_ECHO_INPUT 0x0004
+                #ENABLE_WINDOW_INPUT 0x0008  (default off when a terminal created)
+                #ENABLE_MOUSE_INPUT 0x0010
+                #ENABLE_INSERT_MODE 0X0020
+                #ENABLE_QUICK_EDIT_MODE 0x0040
+                #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512)
+                set h_in [twapi::get_console_handle stdin]
+                set oldmode_in [twapi::GetConsoleMode $h_in]
+                set newmode_in [expr {$oldmode_in | 8}]
+                #set newmode_in [expr {$oldmode_in | 0x208}]
+
+                twapi::SetConsoleMode $h_in $newmode_in
+
+                return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
+            }
+            proc disableAnsi {} {
+                set h_out [twapi::get_console_handle stdout] 
+                set oldmode_out [twapi::GetConsoleMode $h_out]
+                set newmode_out [expr {$oldmode_out & ~4}]
+                twapi::SetConsoleMode $h_out $newmode_out
+
+                #??? review
+                set h_in [twapi::get_console_handle stdin]
+                set oldmode_in [twapi::GetConsoleMode $h_in]
+                set newmode_in [expr {$oldmode_in & ~8}]
+                twapi::SetConsoleMode $h_in $newmode_in
+
+
+                return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
+            }
+            proc enableVirtualTerminal {{channels {input output}}} {
+                set ins [list in input stdin]
+                set outs [list out output stdout stderr]
+                set known [concat $ins $outs both]
+                set directions [list]
+                foreach v $channels {
+                    if {$v in $ins} {
+                        lappend directions input
+                    } elseif {$v in $outs} {
+                        lappend directions output
+                    } elseif {$v eq "both"} {
+                        lappend directions input output
+                    }
+                    if {$v ni $known} {
+                        error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)"
+                    }
+                }
+                set channels $directions ;#don't worry about dups.
+                if {"both" in $channels} {
+                    lappend channels input output
+                }
+                set result [dict create]
+                if {"output" in $channels} {
+                    #note setting stdout makes stderr have the same settings - ie there is really only one output to configure
+                    set h_out [twapi::get_console_handle stdout] 
+                    set oldmode [twapi::GetConsoleMode $h_out]
+                    set newmode [expr {$oldmode | 4}] 
+                    twapi::SetConsoleMode $h_out $newmode
+                    dict set result output [list from $oldmode to $newmode]
+                }
+
+                if {"input" in $channels} {
+                    set h_in [twapi::get_console_handle stdin]
+                    set oldmode_in [twapi::GetConsoleMode $h_in]
+                    set newmode_in [expr {$oldmode_in | 0x200}]
+                    twapi::SetConsoleMode $h_in $newmode_in
+                    dict set result input [list from $oldmode_in to $newmode_in]
+                }
+
+                return $result
+            }
+
+            proc disableVirtualTerminal {{channels {input output}}} {
+                set ins [list in input stdin]
+                set outs [list out output stdout stderr]
+                set known [concat $ins $outs both]
+                set directions [list]
+                foreach v $channels {
+                    if {$v in $ins} {
+                        lappend directions input
+                    } elseif {$v in $outs} {
+                        lappend directions output
+                    } elseif {$v eq "both"} {
+                        lappend directions input output
+                    }
+                    if {$v ni $known} {
+                        error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)"
+                    }
+                }
+                set channels $directions ;#don't worry about dups.
+                if {"both" in $channels} {
+                    lappend channels input output
+                }
+                set result [dict create]
+                if {"output" in $channels} {
+                    #as above - configuring stdout does stderr too
+                    set h_out [twapi::get_console_handle stdout] 
+                    set oldmode [twapi::GetConsoleMode $h_out]
+                    set newmode [expr {$oldmode & ~4}] 
+                    twapi::SetConsoleMode $h_out $newmode
+                    dict set result output [list from $oldmode to $newmode]
+                }
+                if {"input" in $channels} {
+                    set h_in [twapi::get_console_handle stdin]
+                    set oldmode_in [twapi::GetConsoleMode $h_in]
+                    set newmode_in [expr {$oldmode_in & ~0x200}]
+                    twapi::SetConsoleMode $h_in $newmode_in
+                    dict set result input [list from $oldmode_in to $newmode_in]
+                }
+
+                #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
+                return $result
+            }
+            proc enableProcessedInput {} {
+                set h_in [twapi::get_console_handle stdin]
+                set oldmode_in [twapi::GetConsoleMode $h_in]
+                set newmode_in [expr {$oldmode_in | 1}]
+                twapi::SetConsoleMode $h_in $newmode_in
+                return [list stdin [list from $oldmode_in to $newmode_in]]
+            }
+            proc disableProcessedInput {} {
+                set h_in [twapi::get_console_handle stdin]
+                set oldmode_in [twapi::GetConsoleMode $h_in]
+                set newmode_in [expr {$oldmode_in & ~1}]
+                twapi::SetConsoleMode $h_in $newmode_in
+                return [list stdin [list from $oldmode_in to $newmode_in]]
+            }
+            proc enableRaw {{channel stdin}} {
+                #variable is_raw
+                variable previous_stty_state_$channel
+
+                if {[catch {twapi::get_console_handle stdin} console_handle]} {
+                    puts stderr "enableRaw error: twapi cannot get console handle for stdin"
+                    #review. If twapi couldn't get a console handle - no point trying other mechanisms(?)
+                    return
+                }
+                #returns dictionary
+                #e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
+                set oldmode [twapi::get_console_input_mode]
+                twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
+                # Turn off the echo and line-editing bits
+                #set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
+                set newmode [twapi::get_console_input_mode]
+
+                tsv::set console is_raw 1
+                #don't disable handler - it will detect is_raw
+                ###    twapi::set_console_control_handler {}
+                return [list stdin [list from $oldmode to $newmode]]
+            }
+
+            #note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
+            #could be we were missing a step in reopening stdin and console configuration?
+
+            proc disableRaw {{channel stdin}} {
+                #variable is_raw
+                variable previous_stty_state_$channel
+                set ch_state [chan conf $channel]
+                if {[dict exists $ch_state -inputmode]} {
+                    chan conf $channel -inputmode normal
+                    tsv::set console is_raw 0
+                    return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
                 } else {
-                    #error vs noop?
-                    puts stderr "Unable to set implementation for %f% - check twapi?"
+                    if {[catch {twapi::get_console_handle stdin} console_handle]} {
+                        #e.g tkcon/wish
+                        puts stderr "disableRaw error: twapi cannot get console handle for stdin"
+                        return ;# ???
+                    }
+                    set oldmode [twapi::get_console_input_mode]
+                    # Turn on the echo and line-editing bits
+                    twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
+                    set newmode [twapi::get_console_input_mode]
+                    tsv::set console is_raw 0
+                    return [list stdin [list from $oldmode to $newmode]]
                 }
-            }]
+            }
+
+        } else {
+
+            variable ps_consolemode_pid
+            variable ps_consolemode_contents
+            variable ps_pipename
+            if {![info exists ps_consolemode_contents]} {
+                #start persistent powershell consolemode_server.ps1 named pipe server
+                if {$::argv0 ne ""} {
+                    set pstooldir [file dirname [file dirname [file normalize $::argv0]]]/scriptlib/utils/pwsh
+                } else {
+                    set pstooldir [pwd]
+                }
+                #set ps_script $pstooldir/consolemode_server.ps1
+                set ps_script $pstooldir/consolemode_server_async.ps1
+                if {[file exists $ps_script]} {
+                    set fd [open $ps_script r]
+                    chan configure $fd -translation binary
+                    set ps_consoleid [pid]-[expr {int(999 * rand())+1}]
+                    set ps_consolemode_contents [string map [list "<punkshell_consoleid>" $ps_consoleid] [read $fd]]
+                    close $fd
+                    #set ps_consolemode_pipe [twapi::namedpipe_client {//./pipe/punkshell_ps_consolemode} -access write]
+                    #set ps_cmd [auto_execok pwsh.exe]
+                    set ps_cmd [auto_execok pwsh.exe]
+                    if {$ps_cmd eq ""} {
+                        set ps_cmd [auto_execok powershell.exe]
+                    }
+                    if {$ps_cmd ne ""} {
+                        set ps_consolemode_pid [exec {*}$ps_cmd -nop -nol -c $ps_consolemode_contents &]
+                        set ps_pipename {\\.\pipe\punkshell_ps_consolemode_}
+                        append ps_pipename $ps_consoleid
+                        puts stderr "twapi not present, using persistent powershell process: pipename: $ps_pipename pid: $ps_consolemode_pid"
+                        #todo -  taskkill /F /PID $ps_consolemode_pid
+                        #when?
+                        #review
+                        #if {[catch {puts "pidinfo: [::tcl::process::status $ps_consolemode_pid]"} errM]} {
+                        #    puts stderr "--- failed to get process status for $ps_consolemode_pid\n$errM"
+                        #}
+                        #set p [open {\\.\pipe\punkshell_ps_consolemode} w]
+                        #chan conf $p -buffering none -blocking 1
+                        #puts $p ""
+                        #close $p
+                    }
+                }
+
+            }
+
+
+            #enableRaw
+            proc enableRaw {{channel stdin}} {
+                #puts stderr "punk::console::enableRaw"
+                #variable is_raw
+                variable previous_stty_state_$channel
+                variable ps_consolemode_contents
+                variable ps_pipename
+
+
+                if {[info exists ps_consolemode_contents]} {
+                    #ps_pipename e.g \\.\pipe\punkwinshell_ps_consolemode_12345-1223456
+
+                    set trynum 0
+                    set wrote 0
+                    while {$trynum < 5} {
+                        incr trynum
+                        if {![catch {
+                            set pipe [open $ps_pipename w]
+                        } errMsg]} {
+                            chan conf $pipe -buffering line
+                            puts -nonewline $pipe "enableraw\r\n"
+                            #flush $pipe
+                            #after 10
+                            #close $pipe
+                            set wrote 1
+                            break
+                        } else {
+                            after 100
+                        }
+                    }
+                    if {$wrote} {
+                        tsv::set console is_raw 1
+                        #after 100
+                        close $pipe
+                    } else {
+                        puts stderr "write to $ps_pipename failed trynum: $trynum\n$errMsg"
+                    }
+                } elseif {[set sttycmd [auto_execok stty]] ne ""} {
+                    #todo - something else entirely
+                    #this approach does not work on windows
+                    #the msys/cygwin stty command is launched as a subprocess - can be used to retrieve info
+                    # but seems to be useless as far as affecting the calling process/console
+                    if {[set previous_stty_state_$channel] eq ""} {
+                        set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel]
+                    }
+
+                    exec {*}$sttycmd raw -echo <@$channel
+                    tsv::set console is_raw 1
+                    #review - inconsistent return dict
+                    return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]]
+                } else {
+                    error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting"
+                }
+            }
+
+
+            proc disableRaw {{channel stdin}} {
+                variable previous_stty_state_$channel
+                set ch_state [chan conf $channel]
+                if {[dict exists $ch_state -inputmode]} {
+                    chan conf $channel -inputmode normal
+                    tsv::set console is_raw 0
+                    return [list $channel [list from [dict get $ch_state -inputmode] to normal]]
+                } else {
+                    #tcl <= 8.6x doesn't support -inputmode
+                    if {[set sttycmd [auto_execok stty]] ne ""} {
+                        #this doesn't work on windows
+                        #It may seem to - only because running *any* external utility can exit raw mode
+                        set sttycmd [auto_execok stty]
+                        if {[set previous_stty_state_$channel] ne ""} {
+                            exec {*}$sttycmd [set previous_stty_state_$channel]
+                            set previous_stty_state_$channel ""
+                            return restored
+                        }
+                        exec {*}$sttycmd -raw echo <@$channel
+                        tsv::set console is_raw 0
+                        #do we really want to exec stty yet again to show final 'to' state? 
+                        #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states.
+                        return [list stdin  [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]]
+                    } else {
+                        error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting"
+                    }
+                }
+            }
+
+            #enableAnsi
+            proc enableAnsi {} {
+            }
+            #disableAnsi
+            proc enableAnsi {} {
+            }
+            #enableVirtualTerminal
+            proc enableVirtualTerminal {{channels {input output}}} {
+            }
+            #disableVirtualTerminal
+            proc disableVirtualTerminal {{channels {input output}}} {
+            }
+            #enableProcessedInput
+            #disableProcessedInput
+
         }
 
     } else {
+        #non-windows platforms
+
         proc enableAnsi {} {
             #todo?
         }
@@ -190,6 +495,13 @@ namespace eval punk::console {
         #todo - something better - the 'channel' concept may not really apply on unix, as raw mode is set for input and output modes currently - only valid to set on a readable channel?
         #on windows they can be set independently (but not with stty) - REVIEW
 
+        proc enableVirtualTerminal {{channels {input output}}} {
+
+        }
+        proc disableVirtualTerminal {args} {
+
+        }
+
         #NOTE - the is_raw is only being set in current interp - but the channel is shared.
         #this is problematic with the repl thread being separate. - must be a tsv?  REVIEW
         proc enableRaw {{channel stdin}} {
@@ -221,12 +533,6 @@ namespace eval punk::console {
             tsv::set console is_raw 0
             return done
         }
-        proc enableVirtualTerminal {{channels {input output}}} {
-
-        }
-        proc disableVirtualTerminal {args} {
-
-        }
     }
 
     #review - document and decide granularity required. should we enable/disable more than one at once? 
@@ -257,7 +563,6 @@ namespace eval punk::console {
         #puts -nonewline stdout \x1b\[?25l  ;#hide cursor
         puts -nonewline stdout \x1b\[?1003h\n
         enable_bracketed_paste
-        
     }
     #todo stop_application_mode {} {}
 
@@ -313,266 +618,10 @@ namespace eval punk::console {
             }
         }
         proc define_windows_procs {} {
-            package require zzzload
-            set loadstate [zzzload::pkg_require twapi]
-
-            #loadstate could also be stuck on loading? - review - zzzload not very ripe
-            #Twapi can be relatively slow to load (on some systems) - can be 1s plus in some cases - and much longer if there are disk performance issues.
-            if {$loadstate ni [list failed]} {
-                #possibly still 'loading'
-                #review zzzload usage
-                #puts stdout "=========== console loading twapi ============="
-                set loadstate [zzzload::pkg_wait twapi] ;#can return 'failed' will return version if already loaded or loaded during wait
-            }
-
-            if {$loadstate ni [list failed]} {
-                package require twapi ;#should be fast once twapi dll loaded in zzzload thread
-                set ::punk::console::has_twapi 1
-
-                #todo - move some of these to the punk::console::local sub-namespace - as they use APIs rather than in-band ANSI to do their work.
-                #enableAnsi seems like it should be directly under punk::console .. but then it seems inconsistent if other local console-mode setting functions aren't.
-                #Find a compromise to organise things somewhat sensibly..
-
-                #this is really enableAnsi *processing* 
-                proc [namespace parent]::enableAnsi {} {
-                    #output handle modes
-                    #Enable virtual terminal processing (sometimes off in older windows terminals)
-                    #ENABLE_PROCESSED_OUTPUT = 0x0001
-                    #ENABLE_WRAP_AT_EOL_OUTPUT = 0x0002
-                    #ENABLE_VIRTUAL_TERMINAL_PROCESSING = 0x0004
-                    #DISABLE_NEWLINE_AUTO_RETURN = 0x0008
-                    set h_out [twapi::get_console_handle stdout] 
-                    set oldmode_out [twapi::GetConsoleMode $h_out]
-                    set newmode_out [expr {$oldmode_out | 4}] ;#don't enable processed output too, even though it's required. keep symmetrical with disableAnsi?
-
-                    twapi::SetConsoleMode $h_out $newmode_out
-
-                    #what does window_input have to do with it??
-                    #input handle modes
-                    #ENABLE_PROCESSED_INPUT 0x0001  ;#set to zero will allow ctrl-c to be reported as keyboard input rather than as a signal
-                    #ENABLE_LINE_INPUT 0x0002
-                    #ENABLE_ECHO_INPUT 0x0004
-                    #ENABLE_WINDOW_INPUT 0x0008  (default off when a terminal created)
-                    #ENABLE_MOUSE_INPUT 0x0010
-                    #ENABLE_INSERT_MODE 0X0020
-                    #ENABLE_QUICK_EDIT_MODE 0x0040
-                    #ENABLE_VIRTUAL_TERMINAL_INPUT 0x0200 (default off when a terminal created) (512)
-                    set h_in [twapi::get_console_handle stdin]
-                    set oldmode_in [twapi::GetConsoleMode $h_in]
-                    set newmode_in [expr {$oldmode_in | 8}]
-                    #set newmode_in [expr {$oldmode_in | 0x208}]
-
-                    twapi::SetConsoleMode $h_in $newmode_in
-
-                    return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
-                }
-                proc [namespace parent]::disableAnsi {} {
-                    set h_out [twapi::get_console_handle stdout] 
-                    set oldmode_out [twapi::GetConsoleMode $h_out]
-                    set newmode_out [expr {$oldmode_out & ~4}]
-                    twapi::SetConsoleMode $h_out $newmode_out
 
-                    #??? review
-                    set h_in [twapi::get_console_handle stdin]
-                    set oldmode_in [twapi::GetConsoleMode $h_in]
-                    set newmode_in [expr {$oldmode_in & ~8}]
-                    twapi::SetConsoleMode $h_in $newmode_in
-
-
-                    return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
-                }
-
-                #
-                proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
-                    set ins [list in input stdin]
-                    set outs [list out output stdout stderr]
-                    set known [concat $ins $outs both]
-                    set directions [list]
-                    foreach v $channels {
-                        if {$v in $ins} {
-                            lappend directions input
-                        } elseif {$v in $outs} {
-                            lappend directions output
-                        } elseif {$v eq "both"} {
-                            lappend directions input output
-                        }
-                        if {$v ni $known} {
-                            error "enableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)"
-                        }
-                    }
-                    set channels $directions ;#don't worry about dups.
-                    if {"both" in $channels} {
-                        lappend channels input output
-                    }
-                    set result [dict create]
-                    if {"output" in $channels} {
-                        #note setting stdout makes stderr have the same settings - ie there is really only one output to configure
-                        set h_out [twapi::get_console_handle stdout] 
-                        set oldmode [twapi::GetConsoleMode $h_out]
-                        set newmode [expr {$oldmode | 4}] 
-                        twapi::SetConsoleMode $h_out $newmode
-                        dict set result output [list from $oldmode to $newmode]
-                    }
-
-                    if {"input" in $channels} {
-                        set h_in [twapi::get_console_handle stdin]
-                        set oldmode_in [twapi::GetConsoleMode $h_in]
-                        set newmode_in [expr {$oldmode_in | 0x200}]
-                        twapi::SetConsoleMode $h_in $newmode_in
-                        dict set result input [list from $oldmode_in to $newmode_in]
-                    }
-
-                    return $result
-                }
-                proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
-                    set ins [list in input stdin]
-                    set outs [list out output stdout stderr]
-                    set known [concat $ins $outs both]
-                    set directions [list]
-                    foreach v $channels {
-                        if {$v in $ins} {
-                            lappend directions input
-                        } elseif {$v in $outs} {
-                            lappend directions output
-                        } elseif {$v eq "both"} {
-                            lappend directions input output
-                        }
-                        if {$v ni $known} {
-                            error "disableVirtualTerminal expected channel values to be one of '$known'. (all values mapped to input and/or output)"
-                        }
-                    }
-                    set channels $directions ;#don't worry about dups.
-                    if {"both" in $channels} {
-                        lappend channels input output
-                    }
-                    set result [dict create]
-                    if {"output" in $channels} {
-                        #as above - configuring stdout does stderr too
-                        set h_out [twapi::get_console_handle stdout] 
-                        set oldmode [twapi::GetConsoleMode $h_out]
-                        set newmode [expr {$oldmode & ~4}] 
-                        twapi::SetConsoleMode $h_out $newmode
-                        dict set result output [list from $oldmode to $newmode]
-                    }
-                    if {"input" in $channels} {
-                        set h_in [twapi::get_console_handle stdin]
-                        set oldmode_in [twapi::GetConsoleMode $h_in]
-                        set newmode_in [expr {$oldmode_in & ~0x200}]
-                        twapi::SetConsoleMode $h_in $newmode_in
-                        dict set result input [list from $oldmode_in to $newmode_in]
-                    }
-
-                    #return [list stdout [list from $oldmode_out to $newmode_out] stdin [list from $oldmode_in to $newmode_in]]
-                    return $result
-                }
-
-                proc [namespace parent]::enableProcessedInput {} {
-                    set h_in [twapi::get_console_handle stdin]
-                    set oldmode_in [twapi::GetConsoleMode $h_in]
-                    set newmode_in [expr {$oldmode_in | 1}]
-                    twapi::SetConsoleMode $h_in $newmode_in
-                    return [list stdin [list from $oldmode_in to $newmode_in]]
-                }
-                proc [namespace parent]::disableProcessedInput {} {
-                    set h_in [twapi::get_console_handle stdin]
-                    set oldmode_in [twapi::GetConsoleMode $h_in]
-                    set newmode_in [expr {$oldmode_in & ~1}]
-                    twapi::SetConsoleMode $h_in $newmode_in
-                    return [list stdin [list from $oldmode_in to $newmode_in]]
-                }
 
 
 
-            } else {
-            
-                puts stderr "punk::console falling back to stty because twapi load failed"
-                proc [namespace parent]::enableAnsi {} {
-                    puts stderr "punk::console::enableAnsi todo"
-                }
-                proc [namespace parent]::disableAnsi {} {
-                }
-                #?
-                proc [namespace parent]::enableVirtualTerminal {{channels {input output}}} {
-                }
-                proc [namespace parent]::disableVirtualTerminal {{channels {input output}}} {
-                }
-                proc [namespace parent]::enableProcessedInput {args} {
-
-                }
-                proc [namespace parent]::disableProcessedInput {args} {
-
-                }
-
-            }
-
-                proc [namespace parent]::enableRaw {{channel stdin}} {
-                    #variable is_raw
-                    variable previous_stty_state_$channel
-
-                    if {[package provide twapi] ne ""} {
-                        set console_handle [twapi::get_console_handle stdin]
-                        #returns dictionary
-                        #e.g -processedinput 1 -lineinput 1 -echoinput 1 -windowinput 0 -mouseinput 0 -insertmode 1 -quickeditmode 1 -extendedmode 1 -autoposition 0
-                        set oldmode [twapi::get_console_input_mode]
-                        twapi::modify_console_input_mode $console_handle -lineinput 0 -echoinput 0
-                        # Turn off the echo and line-editing bits
-                        #set newmode [dict merge $oldmode [dict create -lineinput 0 -echoinput 0]]
-                        set newmode [twapi::get_console_input_mode]
-
-                        tsv::set console is_raw 1
-                        #don't disable handler - it will detect is_raw
-                        ###    twapi::set_console_control_handler {}
-                        return [list stdin [list from $oldmode to $newmode]]
-                    } elseif {[set sttycmd [auto_execok stty]] ne ""} {
-                        if {[set previous_stty_state_$channel] eq ""} {
-                            set previous_stty_state_$channel [exec {*}$sttycmd -g <@$channel]
-                        }
-
-                        exec {*}$sttycmd raw -echo <@$channel
-                        tsv::set console is_raw 1
-                        #review - inconsistent return dict
-                        return [dict create stdin [list from [set previous_stty_state_$channel] to "" note "fixme - to state not shown"]]
-                    } else {
-                        error "punk::console::enableRaw Unable to use twapi or stty to set raw mode - aborting"
-                    }
-                }
-
-                #note: twapi GetStdHandle & GetConsoleMode & SetConsoleCombo unreliable - fails with invalid handle (somewhat intermittent.. after stdin reopened?)
-                #could be we were missing a step in reopening stdin and console configuration?
-
-                proc [namespace parent]::disableRaw {{channel stdin}} {
-                    #variable is_raw
-                    variable previous_stty_state_$channel
-
-                    if {[package provide twapi] ne ""} {
-                        set console_handle [twapi::get_console_handle stdin]
-                        set oldmode [twapi::get_console_input_mode]
-                        # Turn on the echo and line-editing bits
-                        twapi::modify_console_input_mode $console_handle -lineinput 1 -echoinput 1
-                        set newmode [twapi::get_console_input_mode]
-                        tsv::set console is_raw 0
-                        return [list stdin [list from $oldmode to $newmode]]
-                    } elseif {[set sttycmd [auto_execok stty]] ne ""} {
-                        #stty can return info on windows - but doesn't seem to be able to set anything.
-                        #review - is returned info even valid?
-
-                        set sttycmd [auto_execok stty]
-                        if {[set previous_stty_state_$channel] ne ""} {
-                            exec {*}$sttycmd [set previous_stty_state_$channel]
-                            set previous_stty_state_$channel ""
-                            return restored
-                        }
-                        exec {*}$sttycmd -raw echo <@$channel
-                        tsv::set console is_raw 0
-                        #do we really want to exec stty yet again to show final 'to' state? 
-                        #probably not. We should work out how to read the stty result flags and set a result.. or just limit from,to to showing echo and lineedit states.
-                        return [list stdin  [list from "[set previous_stty_state_$channel]" to "" note "fixme - to state not shown"]]
-                    } else {
-                        error "punk::console::disableRaw Unable to use twapi or stty to unset raw mode - aborting"
-                    }
-                }
-
-
         }
 
         lappend PUNKARGS [list {
@@ -1803,7 +1852,10 @@ namespace eval punk::console {
         #don't set ansi_avaliable here - we want to be able to change things, retest etc.
         if {"windows" eq "$::tcl_platform(platform)"} {
             if {[package provide twapi] ne ""} {
-                set h_out [twapi::get_console_handle stdout]
+                if {[catch {twapi::get_console_handle stdout} h_out]} {
+                    puts stderr "test_can_ansi: twapi cannot get console handle for stdout"
+                    return 0
+                }
                 set existing_mode [twapi::GetConsoleMode $h_out]
                 if {[expr {$existing_mode & 4}]} {
                     #virtual terminal processing happens to be enabled - so it's supported

src/vfs/_vfscommon.vfs/modules/punk/libunknown-0.1.tm

@@ -80,16 +80,7 @@ tcl::namespace::eval punk::libunknown {
             "Experimental set of replacements for default 'package unknown' entries."
         }]
 
-    variable epoch
-    #if {![info exists epoch]} {
-    #    set tmstate     [dict create 0 {}]
-    #    set pkgstate    [dict create 0 {}]
-    #    set tminfo  [dict create current 0 epochs $tmstate]
-    #    set pkginfo [dict create current 0 epochs $pkgstate]
-
-    #    set epoch [dict create tm $tminfo pkg $pkginfo]
-    #}
-
+    variable epoch ;#don't set - can be pre-set cooperatively
 
     variable has_package_files
     if {[catch {package files foobaz}]} {
@@ -111,6 +102,33 @@ tcl::namespace::eval punk::libunknown {
 
     #will use standard mechanism for non zipfs paths in the tm list.
     proc zipfs_tm_UnknownHandler {original name args} {
+        #------------------------------
+        #shortcircuit for builtin static libraries which have no 'package provide' info - review
+        #This occurs for example when running 'bin\runtime.cmd run src\make.tcl shell' with punk902z.exe
+        #
+        #------------------------------
+        set loaded [lsearch -inline -index 1 -nocase [info loaded] $name]
+        if {[llength $loaded] == 2 && [lindex $loaded 0] eq ""} {
+            lassign $loaded _ cased_name
+            interp create ptest
+            ptest eval [list load {} $cased_name]
+            set static_version [ptest eval [list package provide [string tolower $cased_name]]]
+            set pname [string tolower $cased_name]
+            if {$static_version eq ""} {
+                set static_version [ptest eval [list package provide $cased_name]]
+                set pname $cased_name
+            }
+            if {$static_version ne ""} {
+                if {[package vsatisfies $static_version {*}$args]} {
+                    package ifneeded $pname $static_version [list load {} $cased_name]
+                    interp delete ptest
+                    return
+                }
+            }
+            interp delete ptest
+        }
+        #------------------------------
+
         # Import the list of paths to search for packages in module form.
         # Import the pattern used to check package names in detail.
         variable epoch
@@ -1161,7 +1179,12 @@ tcl::namespace::eval punk::libunknown {
         set callerposn [lsearch $args -caller]
         if {$callerposn > -1} {
             set caller [lindex $args $callerposn+1]
-            #puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller\x1b\[m"
+            if {[package provide thread] ne ""} {
+                set tid [thread::id]
+            } else {
+                set tid "-"
+            }
+            #puts stderr "\x1b\[1\;33m punk::libunknown::init - caller:$caller tid:$tid\x1b\[m"
             #puts stderr "punk::libunknown::init auto_path    : $::auto_path"
             #puts stderr "punk::libunknown::init tcl::tm::list: [tcl::tm::list]"
         }
@@ -1184,17 +1207,17 @@ tcl::namespace::eval punk::libunknown {
             puts stderr "punk::libunknown::init - init while empty/unreadable tcl::tm::list and empty/unreadable ::auto_path"
         }
 
-        if {[namespace origin ::package] eq "::punk::libunknown::package"} {
-            #This is far from conclusive - there may be other renamers (e.g commandstack)
+        if {[info commands ::punk::libunknown::package] ne ""} {
+            puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
             return
         }
+        #if {[namespace origin ::package] eq "::punk::libunknown::package"} {
+        #    #This is far from conclusive - there may be other renamers (e.g commandstack)
+        #    return
+        #}
 
 
 
-        if {[info commands ::punk::libunknown::package] ne ""} {
-            puts stderr "punk::libunknown::init already done - unnecessary call? info frame -1: [info frame -1]"
-            return
-        }
         variable epoch
         if {![info exists epoch]} {
             set tmstate     [dict create 0 {added {}}]
@@ -1222,6 +1245,7 @@ tcl::namespace::eval punk::libunknown {
         #   or suffer additional scans.. or document ??
         #ideally init should be called in each interp before any scans for packages so that the list of untracked is minimized.
         set pkgnames [package names]
+        #puts stderr "####### punk::libunknown init called with [llength $pkgnames] package names known"
         foreach p $pkgnames {
             if {[string tolower $p] in {punk::libunknown tcl::zlib tcloo tcl::oo tcl}} {
                 continue

src/vfs/_vfscommon.vfs/modules/punk/mix/templates/utility/scriptappwrappers/multishell.cmd

@@ -940,6 +940,7 @@ if {$nextshelltype ne "tcl" && $nextshelltype ne "none"} {
             #maint: keep this munging in sync with zsh/bash and perl blocks which must also do msys mangling
             if {[regexp {^cmd$|^cmd[.]exe$} $cmdword]} {
                 #need to deal with msys argument munging 
+                puts stderr "cmd call via msys detected. performing translation of /c to //C" 
                 #for now we only deal with /C or /c - todo - other cmd.exe flags?
                 #In this context we would usually only be using cmd.exe /c to launch older 'desktop' powershell to avoid spaced-argument problems - so we aren't expecting other flags 
                 set new_nextshellpath [list $cmdword]
@@ -1228,13 +1229,14 @@ if [[ "$nextshelltype" != "bash" && "$nextshelltype" != "none" ]]; then
         #do not double quote cmdpattern - or it will be treated as literal string
         if [[ "$nextshellpath" =~ $cmdpattern ]]; then
             #for now - tell the user what's going on
-            echo "cmd call via msys detected. performing translation of /c to //c and escaping backslashes in script path"
+            echo "cmd call via msys detected. performing translation of /c to //c and escaping backslashes in script path" >&2
             #flags to cmd.exe such as /c are interpreted by msys as looking like a unix path
             #review - for nextshellpath targets specified in the block for win32 - we don't expect unix paths (?)
             #what about other flags? - can we just double up all forward slashes?
             #maint: keep this munging in sync with the tcl block and perl block which must also do msys munging
             nextshellpath="${nextshellpath// \/[cC] / \/\/c }"
             # echo "new nextshellpath: ${nextshellpath}"
+            #review - 
             #don't double quote this
             script=${script//\\/\\\\}
         fi
@@ -1343,8 +1345,33 @@ if 0 {
 # -- unbalanced braces { } here *even in comments* will cause problems if there was no Tcl exit or return above
 # -- custom script should generally go below the begin_powershell_payload line
 # ## ### ### ### ### ### ### ### ### ### ### ### ### ###
-function GetScriptName { $myInvocation.ScriptName }
-$scriptname = GetScriptName
+#$MyInvocation.ScriptName should probably be considered deprecated
+# https://stackoverflow.com/questions/78511229/how-can-i-choose-between-myinvocation-scriptname-and-myinvocation-pscommandpat
+$runningscriptname = $PSCommandPath
+if (-not $MyInvocation.PSCommandPath) {
+    $callingscriptname = ''
+} else {
+    $callingscriptname = $MyInvocation.PSCommandPath
+}
+#The problem with psmodulepath
+#https://github.com/PowerShell/PowerShell/issues/18108
+# psmodulepath is shared by powershell and pwsh despite not all ps modules being compatible.
+# It is futzed with by powershell/pwsh based on detecting the child process type.
+# a psmodulepath that has been futzed with by pwsh will not work for a child powershell 5 process that isn't launched directly
+#This is inherently unfriendly to situations where an intervening process may be something else such as cmd.exe,tcl,perl etc
+# nevertheless, powershell/pwsh maintainers seem to have taken the MS-centric view of the world that such situations don't exist :/
+#
+#symptoms of these shenannigans not working include things like Get-FileHash failing in powershell desktop
+#
+#We don't know if the original console was pwsh/powershell or cmd.exe, and we need to potentially divert to powershell 5 (desktop) 
+#via tcl or perl etc - or cmd.exe
+if ($PSVersionTable.PSVersion.Major -le 5) {
+    # For Windows PowerShell, we want to remove any PowerShell 7 paths from PSModulePath
+    #snipped from https://github.com/PowerShell/DSC/pull/777/commits/af9b99a4d38e0cf1e54c4bbd89cbb6a8a8598c4e
+    #Presumably users are supposed to know not to have custom paths for powershell desktop containing a 'powershell' subfolder??
+    $env:PSModulePath = ($env:PSModulePath -split ';' | Where-Object { $_ -notlike '*\powershell\*' }) -join ';'
+}
+
 function GetDynamicParamDictionary {
     [CmdletBinding()]
     param(
@@ -1419,11 +1446,11 @@ function GetDynamicParamDictionary {
 #}
 #psmain @args
 #"Timestamp         :    {0,10:yyyy-MM-dd HH:mm:ss}"    -f $(Get-Date)   | write-host
-"Script Name       :    {0}"    -f $scriptname                          | write-host
+#"Running Script Name       :    {0}"    -f $runningscriptname                          | write-host
 "Powershell Version:    {0}"    -f $PSVersionTable.PSVersion.Major      | write-host
-"powershell args   :    {0}"    -f ($args -join ", ")                   | write-host
+#"powershell args   :    {0}"    -f ($args -join ", ")                   | write-host
 # -- --- --- ---
-$thisfileContent = Get-Content $scriptname -Raw
+$thisfileContent = Get-Content $runningscriptname -Raw
 $startTag = ": <<asadmin_start>>"
 $endTag = ": <<asadmin_end>>"
 $pattern = "(?s)`n$startTag[^`n]*`n(.*?)`n$endTag"
@@ -1522,7 +1549,7 @@ if ($match.Success) {
     }
     if (-not (("pwsh", "powershell", "") -contains $nextshell_type)) {
         #nextshell diversion exists for this platform
-        write-host "os: $os pwsh/powershell launching subshell of type: $nextshell_type shellpath: $nextshell_path on script $scriptname"
+        write-host "os: $os pwsh/powershell launching subshell of type: $nextshell_type shellpath: $nextshell_path on script $runningscriptname"
 
         # $arguments = @($($MyInvocation.MyCommand.Path))
         # $arguments += $args
@@ -1530,7 +1557,7 @@ if ($match.Success) {
         # $process = (Start-Process -FilePath $nextshell_path -ArgumentList $arguments -NoNewWindow -Wait)
         # Exit $process.ExitCode
 
-        & $nextshell_path $scriptname $args
+        & $nextshell_path $runningscriptname $args
         exit $LASTEXITCODE
     }
 }

src/vfs/_vfscommon.vfs/modules/punk/repl-0.1.2.tm

@@ -20,18 +20,6 @@ if {[dict exists $stdin_info -mode]} {
 #give up for now
 set tcl_interactive 1
 
-#if {[info commands ::tcl::zipfs::root] ne ""} {
-#    set zr [::tcl::zipfs::root]
-#    if {[file join $zr app modules] in [tcl::tm::list]} {
-#        #todo - better way to find latest version - without package require
-#        set lib [file join $zr app modules punk libunknown.tm]
-#        if {[file exists $lib]} {
-#            source $lib
-#            punk::libunknown::init
-#            #package unknown {punk::libunknown::zipfs_tm_UnknownHandler punk::libunknown::zipfs_tclPkgUnknown}
-#        }
-#    }
-#}
 #-------------------------------------------------------------------------------------
 if {[package provide punk::libunknown] eq ""} {
     #maintenance - also in src/vfs/_config/punk_main.tcl
@@ -59,7 +47,7 @@ if {[package provide punk::libunknown] eq ""} {
     }
     if {$libunknown ne ""} {
         source $libunknown
-        if {[catch {punk::libunknown::init -caller repl} errM]} {
+        if {[catch {punk::libunknown::init -caller triggered_by_repl_package_require} errM]} {
             puts "error initialising punk::libunknown\n$errM"
         }
     }
@@ -525,11 +513,11 @@ proc repl::start {inchan args} {
     set donevalue [set [namespace current]::done]
     if {[lindex $donevalue 0] eq "quit"} {
         puts "-->repl::start end $inchan $args result:'$donevalue'"
-        puts stderr "--> returning [lindex $donevalue 1]"
+        #puts stderr "repl quit --> returning [lindex $donevalue 1]"
         return [lindex $donevalue 1]
     }
     puts "-->repl::start end $inchan $args result:'$donevalue'"
-    puts stderr "__> returning 0"
+    #puts stderr "__> returning 0"
     return 0
 }
 proc repl::post_operations {} {
@@ -1408,7 +1396,6 @@ proc repl::repl_handler {inputchan prompt_config} {
         if {[dict get $original_input_conf -inputmode] eq "raw"} {
             #user or script has apparently put stdin into raw mode - update punk::console::is_raw to match
             set rawmode 1
-            #set ::punk::console::is_raw 1
             tsv::set console is_raw 1
         } else {
             #set ::punk::console::is_raw 0
@@ -1420,9 +1407,6 @@ proc repl::repl_handler {inputchan prompt_config} {
         #if it's been set to raw - assume it is deliberately done this way as the user could have alternatively called punk::mode raw or punk::console::enableVirtualTerminal
         #by not doing this automatically - we assume the caller has a reason.
     } else {
-        #JMN FIX!
-        #this returns 0 in rawmode on 8.6 after repl thread changes
-        #set rawmode [set ::punk::console::is_raw]
         set rawmode [tsv::get console is_raw]
     }
 
@@ -1811,8 +1795,6 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
         set infoprompt      [dict get $prompt_config infoprompt]
         set debugprompt     [dict get $prompt_config debugprompt]
 
-
-        #set rawmode [set ::punk::console::is_raw]
         set rawmode [tsv::get console is_raw]
         if {!$rawmode} {
             #puts stderr "-->got [ansistring VIEW -lf 1 $stdinlines]<--"
@@ -2615,6 +2597,34 @@ proc repl::repl_process_data {inputchan chunktype chunk stdinlines prompt_config
                 }
                 #editbuf
 
+
+                #after any external command - raw mode as the console sees it can be disabled
+                #set it to match current state of the tsv 
+                if {[tsv::get console is_raw]} {
+                    if {$::tcl_platform(platform) eq "windows"} {
+                        #review
+                        #we are in parent process - twapi might not be loaded here - even if it is in the code interp
+                        catch {package require twapi}
+                    }
+                    set sinfo [chan configure stdin]
+                    if {[dict exists $sinfo -inputmode]} {
+                        if {[dict get $sinfo -inputmode] ne "raw"} {
+                            set re_enable_required 1
+                        } else {
+                            set re_enable_required 0
+                        }
+                    } else {
+                        # -inputmode unavailable
+                        #tcl 8.6 doesn't have -inputmode - meaning it has to call punk:console::enableRaw each time
+                        #enableRaw on windows without twapi involves launching a pwsh process - which gives a noticeable lag in keyboard input.
+                        #enableRaw on Unix involves a call to stty - which is generally fast - but still to be avoided if not required.
+                        set re_enable_required 1
+                    }
+                    #puts stderr "-here- re-enabling raw"
+                    if {$re_enable_required} {
+                        punk::console::enableRaw
+                    }
+                }
             } else {
                 #append commandstr \n
                 if {$::punk::repl::signal_control_c} {
@@ -2828,7 +2838,7 @@ namespace eval repl {
             }
             if {$libunknown ne ""} {
                 source $libunknown
-                if {[catch {punk::libunknown::init -caller "repl init_script"} errM]} {
+                if {[catch {punk::libunknown::init -caller "repl::init init_script parent interp"} errM]} {
                     puts "repl::init problem - error initialising punk::libunknown\n$errM"
                 }
                 #package require punk::lib
@@ -2858,10 +2868,10 @@ namespace eval repl {
             #thread::send to caller defined interp targets (reference?)
             #snit required for icomm
             if {[catch {package require snit} errM]} {
-                puts stdout "punk::repl::initscript lib load fail ---snit $errM"
+                #puts stdout "punk::repl::initscript: lib load fail ---snit $errM"
             }
             if {[catch {package require punk::icomm} errM]} {
-                puts stdout "punk::repl::initscript lib load fail ---icomm $errM"
+                #puts stdout "punk::repl::initscript: lib load fail ---icomm $errM"
             }
             #-----
 
@@ -2872,7 +2882,7 @@ namespace eval repl {
                     #first use can raise error being a version number e.g 0.1.0  - why?
                     lassign [tcl::chan::fifo2] ::punk::repl::codethread::repltalk replside
                     } errMsg]} {
-                puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errM"
+                puts stdout "punk::repl::initscript tcl::chan::fifo2 error: $errMsg"
             } else {
                 #experimental?
                 #puts stdout "transferring chan $replside to thread %replthread%"
@@ -3519,6 +3529,8 @@ namespace eval repl {
 
                         #-----------------------------------------------------------------------------
                         if {[package provide punk::libunknown] eq ""} {
+                            namespace eval ::punk::libunknown {}
+                            set ::punk::libunknown::epoch %lib_epoch%
                             set libunks [list]
                             foreach tm_path [tcl::tm::list] {
                                 set punkdir [file join $tm_path punk]
@@ -3543,7 +3555,7 @@ namespace eval repl {
                             }
                             if {$libunknown ne ""} {
                                 source $libunknown
-                                if {[catch {punk::libunknown::init -caller "repl init_script punk"} errM]} {
+                                if {[catch {punk::libunknown::init -caller "repl::init init_script code interp for punk"} errM]} {
                                     puts "error initialising punk::libunknown\n$errM"
                                 }
                             }

src/vfs/punk8_statictwapi.vfs/lib_tcl8/thread2.8.12/pkgIndex.tcl

@@ -0,0 +1,68 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+    # Pre-8.4 Tcl interps we dont support at all.  Bye!
+    # 9.0+ Tcl interps are only supported on 32-bit platforms.
+    if {![package vsatisfies [package provide Tcl] 9.0]
+	    || ($::tcl_platform(pointerSize) != 4)} {
+	return
+    }
+}
+
+# All Tcl 8.4+ interps can [load] Thread 2.8.12
+#
+# For interps that are not thread-enabled, we still call [package ifneeded].
+# This is contrary to the usual convention, but is a good idea because we
+# cannot imagine any other version of Thread that might succeed in a
+# thread-disabled interp.  There's nothing to gain by yielding to other
+# competing callers of [package ifneeded Thread].  On the other hand,
+# deferring the error has the advantage that a script calling
+# [package require Thread] in a thread-disabled interp gets an error message
+# about a thread-disabled interp, instead of the message
+# "can't find package Thread".
+
+package ifneeded Thread 2.8.12 [list load [file join $dir thread2812.dll] [string totitle thread]]
+
+# package Ttrace uses some support machinery.
+
+# In Tcl 8.4 interps we use some older interfaces
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+    package ifneeded Ttrace 2.8.12 "
+    [list proc thread_source {dir} {
+	if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
+		[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
+	    source -encoding utf-8 $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
+	} elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
+	    source -encoding utf-8 [file join $dir .. lib ttrace.tcl]
+	} elseif {[file readable [file join $dir ttrace.tcl]]} {
+	    source -encoding utf-8 [file join $dir ttrace.tcl]
+	}
+	if {[namespace which ::ttrace::update] ne ""} {
+	    ::ttrace::update
+	}
+    }]
+    [list thread_source $dir]
+    [list rename thread_source {}]"
+    return
+}
+
+# In Tcl 8.5+ interps; use [::apply]
+
+package ifneeded Ttrace 2.8.12 [list ::apply {{dir} {
+    if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
+	[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
+	source -encoding utf-8 $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
+    } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
+	source -encoding utf-8 [file join $dir .. lib ttrace.tcl]
+    } elseif {[file readable [file join $dir ttrace.tcl]]} {
+	source -encoding utf-8 [file join $dir ttrace.tcl]
+    }
+    if {[namespace which ::ttrace::update] ne ""} {
+	::ttrace::update
+    }
+}} $dir]
+
+
+

src/vfs/punk8_statictwapi.vfs/lib_tcl8/thread2.8.12/ttrace.tcl

@@ -0,0 +1,942 @@
+#
+# ttrace.tcl --
+#
+# Copyright (C) 2003 Zoran Vasiljevic, Archiware GmbH. All Rights Reserved.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# ----------------------------------------------------------------------------
+#
+# User level commands:
+#
+#   ttrace::eval           top-level wrapper (ttrace-savvy eval)
+#   ttrace::enable         activates registered Tcl command traces
+#   ttrace::disable        terminates tracing of Tcl commands
+#   ttrace::isenabled      returns true if ttrace is enabled
+#   ttrace::cleanup        bring the interp to a pristine state
+#   ttrace::update         update interp to the latest trace epoch
+#   ttrace::config         setup some configuration options
+#   ttrace::getscript      returns a script for initializing interps
+#
+# Commands used for/from trace callbacks:
+#
+#   ttrace::atenable       register callback to be done at trace enable
+#   ttrace::atdisable      register callback to be done at trace disable
+#   ttrace::addtrace       register user-defined tracer callback
+#   ttrace::addscript      register user-defined script generator
+#   ttrace::addresolver    register user-defined command resolver
+#   ttrace::addcleanup     register user-defined cleanup procedures
+#   ttrace::addentry       adds one entry into the named trace store
+#   ttrace::getentry       returns the entry value from the named store
+#   ttrace::delentry       removes the entry from the named store
+#   ttrace::getentries     returns all entries from the named store
+#   ttrace::preload        register procedures to be preloaded always
+#
+#
+# Limitations:
+#
+#   o. [namespace forget] is still not implemented
+#   o. [namespace origin cmd] breaks if cmd is not already defined
+#
+#      I left this deliberately. I didn't want to override the [namespace]
+#      command in order to avoid potential slowdown.
+#
+
+namespace eval ttrace {
+
+    # Setup some compatibility wrappers
+    if {[info commands nsv_set] != ""} {
+	variable tvers 0
+	variable mutex ns_mutex
+	variable elock [$mutex create traceepochmutex]
+	# Import the underlying API; faster than recomputing
+	interp alias {} [namespace current]::_array   {} nsv_array
+	interp alias {} [namespace current]::_incr    {} nsv_incr
+	interp alias {} [namespace current]::_lappend {} nsv_lappend
+	interp alias {} [namespace current]::_names   {} nsv_names
+	interp alias {} [namespace current]::_set     {} nsv_set
+	interp alias {} [namespace current]::_unset   {} nsv_unset
+    } elseif {![catch {
+	variable tvers [package require Thread]
+    }]} {
+	variable mutex thread::mutex
+	variable elock [$mutex create]
+	# Import the underlying API; faster than recomputing
+	interp alias {} [namespace current]::_array   {} tsv::array
+	interp alias {} [namespace current]::_incr    {} tsv::incr
+	interp alias {} [namespace current]::_lappend {} tsv::lappend
+	interp alias {} [namespace current]::_names   {} tsv::names
+	interp alias {} [namespace current]::_set     {} tsv::set
+	interp alias {} [namespace current]::_unset   {} tsv::unset
+    } else {
+	error "requires NaviServer/AOLserver or Tcl threading extension"
+    }
+
+    # Keep in sync with the Thread package
+    package provide Ttrace 2.8.12
+
+    # Package variables
+    variable resolvers ""     ; # List of registered resolvers
+    variable tracers   ""     ; # List of registered cmd tracers
+    variable scripts   ""     ; # List of registered script makers
+    variable enables   ""     ; # List of trace-enable callbacks
+    variable disables  ""     ; # List of trace-disable callbacks
+    variable preloads  ""     ; # List of procedure names to preload
+    variable enabled   0      ; # True if trace is enabled
+    variable config           ; # Array with config options
+
+    variable epoch     -1     ; # The initialization epoch
+    variable cleancnt   0     ; # Counter of registered cleaners
+
+    # Package private namespaces
+    namespace eval resolve "" ; # Commands for resolving commands
+    namespace eval trace   "" ; # Commands registered for tracing
+    namespace eval enable  "" ; # Commands invoked at trace enable
+    namespace eval disable "" ; # Commands invoked at trace disable
+    namespace eval script  "" ; # Commands for generating scripts
+
+    # Exported commands
+    namespace export unknown
+
+    # Initialize ttrace shared state
+    if {[_array exists ttrace] == 0} {
+	_set ttrace lastepoch $epoch
+	_set ttrace epochlist ""
+    }
+
+    # Initially, allow creation of epochs
+    set config(-doepochs) 1
+
+    proc eval {cmd args} {
+	enable
+	set code [catch {uplevel 1 [concat $cmd $args]} result]
+	disable
+	if {$code == 0} {
+	    if {[llength [info commands ns_ictl]]} {
+		ns_ictl save [getscript]
+	    } else {
+		thread::broadcast {
+		    package require Ttrace
+		    ttrace::update
+		}
+	    }
+	}
+	return -code $code \
+	    -errorinfo $::errorInfo -errorcode $::errorCode $result
+    }
+
+    proc config {args} {
+	variable config
+	if {[llength $args] == 0} {
+	    array get config
+	} elseif {[llength $args] == 1} {
+	    set opt [lindex $args 0]
+	    set config($opt)
+	} else {
+	    set opt [lindex $args 0]
+	    set val [lindex $args 1]
+	    set config($opt) $val
+	}
+    }
+
+    proc enable {} {
+	variable config
+	variable tracers
+	variable enables
+	variable enabled
+	incr enabled 1
+	if {$enabled > 1} {
+	    return
+	}
+	if {$config(-doepochs) != 0} {
+	    variable epoch [_newepoch]
+	}
+	set nsp [namespace current]
+	foreach enabler $enables {
+	    enable::_$enabler
+	}
+	foreach trace $tracers {
+	    if {[info commands $trace] != ""} {
+		trace add execution $trace leave ${nsp}::trace::_$trace
+	    }
+	}
+    }
+
+    proc disable {} {
+	variable enabled
+	variable tracers
+	variable disables
+	incr enabled -1
+	if {$enabled > 0} {
+	    return
+	}
+	set nsp [namespace current]
+	foreach disabler $disables {
+	    disable::_$disabler
+	}
+	foreach trace $tracers {
+	    if {[info commands $trace] != ""} {
+		trace remove execution $trace leave ${nsp}::trace::_$trace
+	    }
+	}
+    }
+
+    proc isenabled {} {
+	variable enabled
+	expr {$enabled > 0}
+    }
+
+    proc update {{from -1}} {
+	if {$from < 0} {
+	    variable epoch [_set ttrace lastepoch]
+	} else {
+	    if {[lsearch [_set ttrace epochlist] $from] < 0} {
+		error "no such epoch: $from"
+	    }
+	    variable epoch $from
+	}
+	uplevel 1 [getscript]
+    }
+
+    proc getscript {} {
+	variable preloads
+	variable epoch
+	variable scripts
+	append script [_serializensp] \n
+	append script "::namespace eval [namespace current] {" \n
+	append script "::namespace export unknown" \n
+	append script "_useepoch $epoch" \n
+	append script "}" \n
+	foreach cmd $preloads {
+	    append script [_serializeproc $cmd] \n
+	}
+	foreach maker $scripts {
+	    append script [script::_$maker]
+	}
+	return $script
+    }
+
+    proc cleanup {args} {
+	foreach cmd [info commands resolve::cleaner_*] {
+	    uplevel 1 $cmd $args
+	}
+    }
+
+    proc preload {cmd} {
+	variable preloads
+	if {[lsearch $preloads $cmd] < 0} {
+	    lappend preloads $cmd
+	}
+    }
+
+    proc atenable {cmd arglist body} {
+	variable enables
+	if {[lsearch $enables $cmd] < 0} {
+	    lappend enables $cmd
+	    set cmd [namespace current]::enable::_$cmd
+	    proc $cmd $arglist $body
+	    return $cmd
+	}
+    }
+
+    proc atdisable {cmd arglist body} {
+	variable disables
+	if {[lsearch $disables $cmd] < 0} {
+	    lappend disables $cmd
+	    set cmd [namespace current]::disable::_$cmd
+	    proc $cmd $arglist $body
+	    return $cmd
+	}
+    }
+
+    proc addtrace {cmd arglist body} {
+	variable tracers
+	if {[lsearch $tracers $cmd] < 0} {
+	    lappend tracers $cmd
+	    set tracer [namespace current]::trace::_$cmd
+	    proc $tracer $arglist $body
+	    if {[isenabled]} {
+		trace add execution $cmd leave $tracer
+	    }
+	    return $tracer
+	}
+    }
+
+    proc addscript {cmd body} {
+	variable scripts
+	if {[lsearch $scripts $cmd] < 0} {
+	    lappend scripts $cmd
+	    set cmd [namespace current]::script::_$cmd
+	    proc $cmd args $body
+	    return $cmd
+	}
+    }
+
+    proc addresolver {cmd arglist body} {
+	variable resolvers
+	if {[lsearch $resolvers $cmd] < 0} {
+	    lappend resolvers $cmd
+	    set cmd [namespace current]::resolve::$cmd
+	    proc $cmd $arglist $body
+	    return $cmd
+	}
+    }
+
+    proc addcleanup {body} {
+	variable cleancnt
+	set cmd [namespace current]::resolve::cleaner_[incr cleancnt]
+	proc $cmd args $body
+	return $cmd
+    }
+
+    proc addentry {cmd var val} {
+	variable epoch
+	_set ${epoch}-$cmd $var $val
+    }
+
+    proc delentry {cmd var} {
+	variable epoch
+	set ei $::errorInfo
+	set ec $::errorCode
+	catch {_unset ${epoch}-$cmd $var}
+	set ::errorInfo $ei
+	set ::errorCode $ec
+    }
+
+    proc getentry {cmd var} {
+	variable epoch
+	set ei $::errorInfo
+	set ec $::errorCode
+	if {[catch {_set ${epoch}-$cmd $var} val]} {
+	    set ::errorInfo $ei
+	    set ::errorCode $ec
+	    set val ""
+	}
+	return $val
+    }
+
+    proc getentries {cmd {pattern *}} {
+	variable epoch
+	_array names ${epoch}-$cmd $pattern
+    }
+
+    proc unknown {args} {
+	set cmd [lindex $args 0]
+	if {[uplevel 1 ttrace::_resolve [list $cmd]]} {
+	    set c [catch {uplevel 1 $cmd [lrange $args 1 end]} r]
+	} else {
+	    set c [catch {uplevel 1 ::tcl::unknown $args} r]
+	}
+	return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r
+    }
+
+    proc _resolve {cmd} {
+	variable resolvers
+	foreach resolver $resolvers {
+	    if {[uplevel 1 [info comm resolve::$resolver] [list $cmd]]} {
+		return 1
+	    }
+	}
+	return 0
+    }
+
+    proc _getthread {} {
+	if {[info commands ns_thread] == ""} {
+	    thread::id
+	} else {
+	    ns_thread getid
+	}
+    }
+
+    proc _getthreads {} {
+	if {[info commands ns_thread] == ""} {
+	    return [thread::names]
+	} else {
+	    foreach entry [ns_info threads] {
+		lappend threads [lindex $entry 2]
+	    }
+	    return $threads
+	}
+    }
+
+    proc _newepoch {} {
+	variable elock
+	variable mutex
+	$mutex lock $elock
+	set old [_set ttrace lastepoch]
+	set new [_incr ttrace lastepoch]
+	_lappend ttrace $new [_getthread]
+	if {$old >= 0} {
+	    _copyepoch $old $new
+	    _delepochs
+	}
+	_lappend ttrace epochlist $new
+	$mutex unlock $elock
+	return $new
+    }
+
+    proc _copyepoch {old new} {
+	foreach var [_names $old-*] {
+	    set cmd [lindex [split $var -] 1]
+	    _array reset $new-$cmd [_array get $var]
+	}
+    }
+
+    proc _delepochs {} {
+	set tlist [_getthreads]
+	set elist ""
+	foreach epoch [_set ttrace epochlist] {
+	    if {[_dropepoch $epoch $tlist] == 0} {
+		lappend elist $epoch
+	    } else {
+		_unset ttrace $epoch
+	    }
+	}
+	_set ttrace epochlist $elist
+    }
+
+    proc _dropepoch {epoch threads} {
+	set self [_getthread]
+	foreach tid [_set ttrace $epoch] {
+	    if {$tid != $self && [lsearch $threads $tid] >= 0} {
+		lappend alive $tid
+	    }
+	}
+	if {[info exists alive]} {
+	    _set ttrace $epoch $alive
+	    return 0
+	} else {
+	    foreach var [_names $epoch-*] {
+		_unset $var
+	    }
+	    return 1
+	}
+    }
+
+    proc _useepoch {epoch} {
+	if {$epoch >= 0} {
+	    set tid [_getthread]
+	    if {[lsearch [_set ttrace $epoch] $tid] == -1} {
+		_lappend ttrace $epoch $tid
+	    }
+	}
+    }
+
+    proc _serializeproc {cmd} {
+	set dargs [info args $cmd]
+	set pbody [info body $cmd]
+	set pargs ""
+	foreach arg $dargs {
+	    if {![info default $cmd $arg def]} {
+		lappend pargs $arg
+	    } else {
+		lappend pargs [list $arg $def]
+	    }
+	}
+	set nsp [namespace qual $cmd]
+	if {$nsp == ""} {
+	    set nsp "::"
+	}
+	append res [list ::namespace eval $nsp] " {" \n
+	append res [list ::proc [namespace tail $cmd] $pargs $pbody] \n
+	append res "}" \n
+    }
+
+    proc _serializensp {{nsp ""} {result _}} {
+	upvar $result res
+	if {$nsp == ""} {
+	    set nsp [namespace current]
+	}
+	append res [list ::namespace eval $nsp] " {" \n
+	foreach var [info vars ${nsp}::*] {
+	    set vname [namespace tail $var]
+	    if {[array exists $var] == 0} {
+		append res [list ::variable $vname [set $var]] \n
+	    } else {
+		append res [list ::variable $vname] \n
+		append res [list ::array set $vname [array get $var]] \n
+	    }
+	}
+	foreach cmd [info procs ${nsp}::*] {
+	    append res [_serializeproc $cmd] \n
+	}
+	append res "}" \n
+	foreach nn [namespace children $nsp] {
+	    _serializensp $nn res
+	}
+	return $res
+    }
+}
+
+#
+# The code below is ment to be run once during the application start.  It
+# provides implementation of tracing callbacks for some Tcl commands.  Users
+# can supply their own tracer implementations on-the-fly.
+#
+# The code below will create traces for the following Tcl commands:
+#    "namespace", "variable", "load", "proc" and "rename"
+#
+# Also, the Tcl object extension XOTcl 1.1.0 is handled and all XOTcl related
+# things, like classes and objects are traced (many thanks to Gustaf Neumann
+# from XOTcl for his kind help and support).
+#
+
+eval {
+
+    #
+    # Register the "load" trace. This will create the following key/value pair
+    # in the "load" store:
+    #
+    #  --- key ----              --- value ---
+    #  <path_of_loaded_image>    <name_of_the_init_proc>
+    #
+    # We normally need only the name_of_the_init_proc for being able to load
+    # the package in other interpreters, but we store the path to the image
+    # file as well.
+    #
+
+    ttrace::addtrace load {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set image [lindex $cmdline 1]
+	set initp [lindex $cmdline 2]
+	if {$initp == ""} {
+	    foreach pkg [info loaded] {
+		if {[lindex $pkg 0] == $image} {
+		    set initp [lindex $pkg 1]
+		}
+	    }
+	}
+	ttrace::addentry load $image $initp
+    }
+
+    ttrace::addscript load {
+	append res "\n"
+	foreach entry [ttrace::getentries load] {
+	    set initp [ttrace::getentry load $entry]
+	    append res "::load {} $initp" \n
+	}
+	return $res
+    }
+
+    #
+    # Register the "namespace" trace. This will create the following key/value
+    # entry in "namespace" store:
+    #
+    #  --- key ----                   --- value ---
+    #  ::fully::qualified::namespace  1
+    #
+    # It will also fill the "proc" store for procedures and commands imported
+    # in this namespace with following:
+    #
+    #  --- key ----                   --- value ---
+    #  ::fully::qualified::proc       [list <ns>  "" ""]
+    #
+    # The <ns> is the name of the namespace where the command or procedure is
+    # imported from.
+    #
+
+    ttrace::addtrace namespace {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set nop [lindex $cmdline 1]
+	set cns [uplevel 1 namespace current]
+	if {$cns == "::"} {
+	    set cns ""
+	}
+	switch -glob $nop {
+	    eva* {
+		set nsp [lindex $cmdline 2]
+		if {![string match "::*" $nsp]} {
+		    set nsp ${cns}::$nsp
+		}
+		ttrace::addentry namespace $nsp 1
+	    }
+	    imp* {
+		# - parse import arguments (skip opt "-force")
+		set opts [lrange $cmdline 2 end]
+		if {[string match "-fo*" [lindex $opts 0]]} {
+		    set opts [lrange $cmdline 3 end]
+		}
+		# - register all imported procs and commands
+		foreach opt $opts {
+		    if {![string match "::*" [::namespace qual $opt]]} {
+			set opt ${cns}::$opt
+		    }
+		    # - first import procs
+		    foreach entry [ttrace::getentries proc $opt] {
+			set cmd ${cns}::[::namespace tail $entry]
+			set nsp [::namespace qual $entry]
+			set done($cmd) 1
+			set entry [list 0 $nsp "" ""]
+			ttrace::addentry proc $cmd $entry
+		    }
+
+		    # - then import commands
+		    foreach entry [info commands $opt] {
+			set cmd ${cns}::[::namespace tail $entry]
+			set nsp [::namespace qual $entry]
+			if {[info exists done($cmd)] == 0} {
+			    set entry [list 0 $nsp "" ""]
+			    ttrace::addentry proc $cmd $entry
+			}
+		    }
+		}
+	    }
+	}
+    }
+
+    ttrace::addscript namespace {
+	append res \n
+	foreach entry [ttrace::getentries namespace] {
+	    append res "::namespace eval $entry {}" \n
+	}
+	return $res
+    }
+
+    #
+    # Register the "variable" trace. This will create the following key/value
+    # entry in the "variable" store:
+    #
+    #  --- key ----                   --- value ---
+    #  ::fully::qualified::variable   1
+    #
+    # The variable value itself is ignored at the time of
+    # trace/collection. Instead, we take the real value at the time of script
+    # generation.
+    #
+
+    ttrace::addtrace variable {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set opts [lrange $cmdline 1 end]
+	if {[llength $opts]} {
+	    set cns [uplevel 1 namespace current]
+	    if {$cns == "::"} {
+		set cns ""
+	    }
+	    foreach {var val} $opts {
+		if {![string match "::*" $var]} {
+		    set var ${cns}::$var
+		}
+		ttrace::addentry variable $var 1
+	    }
+	}
+    }
+
+    ttrace::addscript variable {
+	append res \n
+	foreach entry [ttrace::getentries variable] {
+	    set cns [namespace qual $entry]
+	    set var [namespace tail $entry]
+	    append res "::namespace eval $cns {" \n
+	    append res "::variable $var"
+	    if {[array exists $entry]} {
+		append res "\n::array set $var [list [array get $entry]]" \n
+	    } elseif {[info exists $entry]} {
+		append res " [list [set $entry]]" \n
+	    } else {
+		append res \n
+	    }
+	    append res "}" \n
+	}
+	return $res
+    }
+
+
+    #
+    # Register the "rename" trace. It will create the following key/value pair
+    # in "rename" store:
+    #
+    #  --- key ----              --- value ---
+    #  ::fully::qualified::old  ::fully::qualified::new
+    #
+    # The "new" value may be empty, for commands that have been deleted. In
+    # such cases we also remove any traced procedure definitions.
+    #
+
+    ttrace::addtrace rename {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set cns [uplevel 1 namespace current]
+	if {$cns == "::"} {
+	    set cns ""
+	}
+	set old [lindex $cmdline 1]
+	if {![string match "::*" $old]} {
+	    set old ${cns}::$old
+	}
+	set new [lindex $cmdline 2]
+	if {$new != ""} {
+	    if {![string match "::*" $new]} {
+		set new ${cns}::$new
+	    }
+	    ttrace::addentry rename $old $new
+	} else {
+	    ttrace::delentry proc $old
+	}
+    }
+
+    ttrace::addscript rename {
+	append res \n
+	foreach old [ttrace::getentries rename] {
+	    set new [ttrace::getentry rename $old]
+	    append res "::rename $old {$new}" \n
+	}
+	return $res
+    }
+
+    #
+    # Register the "proc" trace. This will create the following key/value pair
+    # in the "proc" store:
+    #
+    #  --- key ----              --- value ---
+    #  ::fully::qualified::proc  [list <epoch> <ns> <arglist> <body>]
+    #
+    # The <epoch> chages anytime one (re)defines a proc.  The <ns> is the
+    # namespace where the command was imported from. If empty, the <arglist>
+    # and <body> will hold the actual procedure definition. See the
+    # "namespace" tracer implementation also.
+    #
+
+    ttrace::addtrace proc {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set cns [uplevel 1 namespace current]
+	if {$cns == "::"} {
+	    set cns ""
+	}
+	set cmd [lindex $cmdline 1]
+	if {![string match "::*" $cmd]} {
+	    set cmd ${cns}::$cmd
+	}
+	set dargs [info args $cmd]
+	set pbody [info body $cmd]
+	set pargs ""
+	foreach arg $dargs {
+	    if {![info default $cmd $arg def]} {
+		lappend pargs $arg
+	    } else {
+		lappend pargs [list $arg $def]
+	    }
+	}
+	set pdef [ttrace::getentry proc $cmd]
+	if {$pdef == ""} {
+	    set epoch -1 ; # never traced before
+	} else {
+	    set epoch [lindex $pdef 0]
+	}
+	ttrace::addentry proc $cmd [list [incr epoch] "" $pargs $pbody]
+    }
+
+    ttrace::addscript proc {
+	return {
+	    if {[info command ::tcl::unknown] == ""} {
+		rename ::unknown ::tcl::unknown
+		namespace import -force ::ttrace::unknown
+	    }
+	    if {[info command ::tcl::info] == ""} {
+		rename ::info ::tcl::info
+	    }
+	    proc ::info args {
+		set cmd [lindex $args 0]
+		set hit [lsearch -glob {commands procs args default body} $cmd*]
+		if {$hit > 1} {
+		    if {[catch {uplevel 1 ::tcl::info $args}]} {
+			uplevel 1 ttrace::_resolve [list [lindex $args 1]]
+		    }
+		    return [uplevel 1 ::tcl::info $args]
+		}
+		if {$hit == -1} {
+		    return [uplevel 1 ::tcl::info $args]
+		}
+		set cns [uplevel 1 namespace current]
+		if {$cns == "::"} {
+		    set cns ""
+		}
+		set pat [lindex $args 1]
+		if {![string match "::*" $pat]} {
+		    set pat ${cns}::$pat
+		}
+		set fns [ttrace::getentries proc $pat]
+		if {[string match $cmd* commands]} {
+		    set fns [concat $fns [ttrace::getentries xotcl $pat]]
+		}
+		foreach entry $fns {
+		    if {$cns != [namespace qual $entry]} {
+			set lazy($entry) 1
+		    } else {
+			set lazy([namespace tail $entry]) 1
+		    }
+		}
+		foreach entry [uplevel 1 ::tcl::info $args] {
+		    set lazy($entry) 1
+		}
+		array names lazy
+	    }
+	}
+    }
+
+    #
+    # Register procedure resolver. This will try to resolve the command in the
+    # current namespace first, and if not found, in global namespace.  It also
+    # handles commands imported from other namespaces.
+    #
+
+    ttrace::addresolver resolveprocs {cmd {export 0}} {
+	set cns [uplevel 1 namespace current]
+	set name [namespace tail $cmd]
+	if {$cns == "::"} {
+	    set cns ""
+	}
+	if {![string match "::*" $cmd]} {
+	    set ncmd ${cns}::$cmd
+	    set gcmd ::$cmd
+	} else {
+	    set ncmd $cmd
+	    set gcmd $cmd
+	}
+	set pdef [ttrace::getentry proc $ncmd]
+	if {$pdef == ""} {
+	    set pdef [ttrace::getentry proc $gcmd]
+	    if {$pdef == ""} {
+		return 0
+	    }
+	    set cmd $gcmd
+	} else {
+	    set cmd $ncmd
+	}
+	set epoch [lindex $pdef 0]
+	set pnsp  [lindex $pdef 1]
+	if {$pnsp != ""} {
+	    set nsp [namespace qual $cmd]
+	    if {$nsp == ""} {
+		set nsp ::
+	    }
+	    set cmd ${pnsp}::$name
+	    if {[resolveprocs $cmd 1] == 0 && [info commands $cmd] == ""} {
+		return 0
+	    }
+	    namespace eval $nsp "namespace import -force $cmd"
+	} else {
+	    uplevel 0 [list ::proc $cmd [lindex $pdef 2] [lindex $pdef 3]]
+	    if {$export} {
+		set nsp [namespace qual $cmd]
+		if {$nsp == ""} {
+		    set nsp ::
+		}
+		namespace eval $nsp "namespace export $name"
+	    }
+	}
+	variable resolveproc
+	set resolveproc($cmd) $epoch
+	return 1
+    }
+
+    #
+    # For XOTcl, the entire item introspection/tracing is delegated to XOTcl
+    # itself. The xotcl store is filled with this:
+    #
+    #  --- key ----               --- value ---
+    #  ::fully::qualified::item   <body>
+    #
+    # The <body> is the script used to generate the entire item (class,
+    # object). Note that we do not fill in this during code tracing. It is
+    # done during the script generation. In this step, only the placeholder is
+    # set.
+    #
+    # NOTE: we assume all XOTcl commands are imported in global namespace
+    #
+
+    ttrace::atenable XOTclEnabler {args} {
+	if {[info commands ::xotcl::Class] == ""} {
+	    return
+	}
+	if {[info commands ::xotcl::_creator] == ""} {
+	    ::xotcl::Class create ::xotcl::_creator -instproc create {args} {
+		set result [next]
+		if {![string match ::xotcl::_* $result]} {
+		    ttrace::addentry xotcl $result ""
+		}
+		return $result
+	    }
+	}
+	::xotcl::Class instmixin ::xotcl::_creator
+    }
+
+    ttrace::atdisable XOTclDisabler {args} {
+	if {   [info commands ::xotcl::Class] == ""
+	    || [info commands ::xotcl::_creator] == ""} {
+	    return
+	}
+	::xotcl::Class instmixin ""
+	::xotcl::_creator destroy
+    }
+
+    set resolver [ttrace::addresolver resolveclasses {classname} {
+	set cns [uplevel 1 namespace current]
+	set script [ttrace::getentry xotcl $classname]
+	if {$script == ""} {
+	    set name [namespace tail $classname]
+	    if {$cns == "::"} {
+		set script [ttrace::getentry xotcl ::$name]
+	    } else {
+		set script [ttrace::getentry xotcl ${cns}::$name]
+		if {$script == ""} {
+		    set script [ttrace::getentry xotcl ::$name]
+		}
+	    }
+	    if {$script == ""} {
+		return 0
+	    }
+	}
+	uplevel 1 [list namespace eval $cns $script]
+	return 1
+    }]
+
+    ttrace::addscript xotcl [subst -nocommands {
+	if {![catch {Serializer new} ss]} {
+	    foreach entry [ttrace::getentries xotcl] {
+		if {[ttrace::getentry xotcl \$entry] == ""} {
+		    ttrace::addentry xotcl \$entry [\$ss serialize \$entry]
+		}
+	    }
+	    \$ss destroy
+	    return {::xotcl::Class proc __unknown name {$resolver \$name}}
+	}
+    }]
+
+    #
+    # Register callback to be called on cleanup. This will trash lazily loaded
+    # procs which have changed since.
+    #
+
+    ttrace::addcleanup {
+	variable resolveproc
+	foreach cmd [array names resolveproc] {
+	    set def [ttrace::getentry proc $cmd]
+	    if {$def != ""} {
+		set new [lindex $def 0]
+		set old $resolveproc($cmd)
+		if {[info command $cmd] != "" && $new != $old} {
+		    catch {rename $cmd ""}
+		}
+	    }
+	}
+    }
+}
+
+# EOF
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# tab-width: 8
+# indent-tabs-mode: nil
+# End:

src/vfs/punk8win.vfs/lib_tcl8/tclparser1.9/pkgIndex.tcl

@@ -0,0 +1,2 @@
+package ifneeded parser 1.9 \
+    [list load [file join $dir tclparser19.dll]]

src/vfs/punk8win.vfs/lib_tcl8/tdbc1.1.12/pkgIndex.tcl

@@ -0,0 +1,26 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+# Make sure that TDBC is running in a compatible version of Tcl, and
+# that TclOO is available.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+    return
+}
+apply {{dir} {
+    set libraryfile [file join $dir tdbc.tcl]
+    if {![file exists $libraryfile] && [info exists ::env(TDBC_LIBRARY)]} {
+	set libraryfile [file join $::env(TDBC_LIBRARY) tdbc.tcl]
+    }
+    if {[package vsatisfies [package provide Tcl] 9.0-]} {
+	package ifneeded tdbc 1.1.12 \
+		"package require TclOO;\
+		[list load [file join $dir tcl9tdbc1112.dll] [string totitle tdbc]]\;\
+		[list source -encoding utf-8 $libraryfile]"
+    } else {
+	package ifneeded tdbc 1.1.12 \
+		"package require TclOO;\
+		[list load [file join $dir tdbc1112.dll] [string totitle tdbc]]\;\
+		[list source -encoding utf-8 $libraryfile]"
+    }
+}} $dir

src/vfs/punk8win.vfs/lib_tcl8/tdbc1.1.12/tdbc.tcl

@@ -0,0 +1,922 @@
+# tdbc.tcl --
+#
+#	Definitions of base classes from which TDBC drivers' connections,
+#	statements and result sets may inherit.
+#
+# Copyright (c) 2008 by Kevin B. Kenny
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id$
+#
+#------------------------------------------------------------------------------
+
+package require TclOO
+
+namespace eval ::tdbc {
+    namespace export connection statement resultset
+    variable generalError [list TDBC GENERAL_ERROR HY000 {}]
+}
+
+#------------------------------------------------------------------------------
+#
+# tdbc::ParseConvenienceArgs --
+#
+#	Parse the convenience arguments to a TDBC 'execute',
+#	'executewithdictionary', or 'foreach' call.
+#
+# Parameters:
+#	argv - Arguments to the call
+#	optsVar -- Name of a variable in caller's scope that will receive
+#		   a dictionary of the supplied options
+#
+# Results:
+#	Returns any args remaining after parsing the options.
+#
+# Side effects:
+#	Sets the 'opts' dictionary to the options.
+#
+#------------------------------------------------------------------------------
+
+proc tdbc::ParseConvenienceArgs {argv optsVar} {
+
+    variable generalError
+    upvar 1 $optsVar opts
+
+    set opts [dict create -as dicts]
+    set i 0
+
+    # Munch keyword options off the front of the command arguments
+
+    foreach {key value} $argv {
+	if {[string index $key 0] eq {-}} {
+	    switch -regexp -- $key {
+		-as? {
+		    if {$value ne {dicts} && $value ne {lists}} {
+			set errorcode $generalError
+			lappend errorcode badVarType $value
+			return -code error \
+			    -errorcode $errorcode \
+			    "bad variable type \"$value\":\
+			     must be lists or dicts"
+		    }
+		    dict set opts -as $value
+		}
+		-c(?:o(?:l(?:u(?:m(?:n(?:s(?:v(?:a(?:r(?:i(?:a(?:b(?:le?)?)?)?)?)?)?)?)?)?)?)?)?) {
+		    dict set opts -columnsvariable $value
+		}
+		-- {
+		    incr i
+		    break
+		}
+		default {
+		    set errorcode $generalError
+		    lappend errorcode badOption $key
+		    return -code error \
+			-errorcode $errorcode \
+			"bad option \"$key\":\
+			must be -as or -columnsvariable"
+		}
+	    }
+	} else {
+	    break
+	}
+	incr i 2
+    }
+
+    return [lrange $argv[set argv {}] $i end]
+
+}
+
+
+
+#------------------------------------------------------------------------------
+#
+# tdbc::connection --
+#
+#	Class that represents a generic connection to a database.
+#
+#-----------------------------------------------------------------------------
+
+oo::class create ::tdbc::connection {
+
+    # statementSeq is the sequence number of the last statement created.
+    # statementClass is the name of the class that implements the
+    #	'statement' API.
+    # primaryKeysStatement is the statement that queries primary keys
+    # foreignKeysStatement is the statement that queries foreign keys
+
+    variable statementSeq primaryKeysStatement foreignKeysStatement
+
+    # The base class constructor accepts no arguments.  It sets up the
+    # machinery to do the bookkeeping to keep track of what statements
+    # are associated with the connection.  The derived class constructor
+    # is expected to set the variable, 'statementClass' to the name
+    # of the class that represents statements, so that the 'prepare'
+    # method can invoke it.
+
+    constructor {} {
+	set statementSeq 0
+	namespace eval Stmt {}
+    }
+
+    # The 'close' method is simply an alternative syntax for destroying
+    # the connection.
+
+    method close {} {
+	my destroy
+    }
+
+    # The 'prepare' method creates a new statement against the connection,
+    # giving its constructor the current statement and the SQL code to
+    # prepare.  It uses the 'statementClass' variable set by the constructor
+    # to get the class to instantiate.
+
+    method prepare {sqlcode} {
+	return [my statementCreate Stmt::[incr statementSeq] [self] $sqlcode]
+    }
+
+    # The 'statementCreate' method delegates to the constructor
+    # of the class specified by the 'statementClass' variable. It's
+    # intended for drivers designed before tdbc 1.0b10. Current ones
+    # should forward this method to the constructor directly.
+
+    method statementCreate {name instance sqlcode} {
+	my variable statementClass
+	return [$statementClass create $name $instance $sqlcode]
+    }
+
+    # Derived classes are expected to implement the 'prepareCall' method,
+    # and have it call 'prepare' as needed (or do something else and
+    # install the resulting statement)
+
+    # The 'statements' method lists the statements active against this
+    # connection.
+
+    method statements {} {
+	info commands Stmt::*
+    }
+
+    # The 'resultsets' method lists the result sets active against this
+    # connection.
+
+    method resultsets {} {
+	set retval {}
+	foreach statement [my statements] {
+	    foreach resultset [$statement resultsets] {
+		lappend retval $resultset
+	    }
+	}
+	return $retval
+    }
+
+    # The 'transaction' method executes a block of Tcl code as an
+    # ACID transaction against the database.
+
+    method transaction {script} {
+	my begintransaction
+	set status [catch {uplevel 1 $script} result options]
+	if {$status in {0 2 3 4}} {
+	    set status2 [catch {my commit} result2 options2]
+	    if {$status2 == 1} {
+		set status 1
+		set result $result2
+		set options $options2
+	    }
+	}
+	switch -exact -- $status {
+	    0 {
+		# do nothing
+	    }
+	    2 - 3 - 4 {
+		set options [dict merge {-level 1} $options[set options {}]]
+		dict incr options -level
+	    }
+	    default {
+		my rollback
+	    }
+	}
+	return -options $options $result
+    }
+
+    # The 'allrows' method prepares a statement, then executes it with
+    # a given set of substituents, returning a list of all the rows
+    # that the statement returns. Optionally, it stores the names of
+    # the columns in '-columnsvariable'.
+    # Usage:
+    #     $db allrows ?-as lists|dicts? ?-columnsvariable varName? ?--?
+    #	      sql ?dictionary?
+
+    method allrows args {
+
+	variable ::tdbc::generalError
+
+	# Grab keyword-value parameters
+
+	set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+	# Check postitional parameters
+
+	set cmd [list [self] prepare]
+	if {[llength $args] == 1} {
+	    set sqlcode [lindex $args 0]
+	} elseif {[llength $args] == 2} {
+	    lassign $args sqlcode dict
+	} else {
+	    set errorcode $generalError
+	    lappend errorcode wrongNumArgs
+	    return -code error -errorcode $errorcode \
+		"wrong # args: should be [lrange [info level 0] 0 1]\
+		 ?-option value?... ?--? sqlcode ?dictionary?"
+	}
+	lappend cmd $sqlcode
+
+	# Prepare the statement
+
+	set stmt [uplevel 1 $cmd]
+
+	# Delegate to the statement to accumulate the results
+
+	set cmd [list $stmt allrows {*}$opts --]
+	if {[info exists dict]} {
+	    lappend cmd $dict
+	}
+	set status [catch {
+	    uplevel 1 $cmd
+	} result options]
+
+	# Destroy the statement
+
+	catch {
+	    $stmt close
+	}
+
+	return -options $options $result
+    }
+
+    # The 'foreach' method prepares a statement, then executes it with
+    # a supplied set of substituents.  For each row of the result,
+    # it sets a variable to the row and invokes a script in the caller's
+    # scope.
+    #
+    # Usage:
+    #     $db foreach ?-as lists|dicts? ?-columnsVariable varName? ?--?
+    #         varName sql ?dictionary? script
+
+    method foreach args {
+
+	variable ::tdbc::generalError
+
+	# Grab keyword-value parameters
+
+	set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+	# Check postitional parameters
+
+	set cmd [list [self] prepare]
+	if {[llength $args] == 3} {
+	    lassign $args varname sqlcode script
+	} elseif {[llength $args] == 4} {
+	    lassign $args varname sqlcode dict script
+	} else {
+	    set errorcode $generalError
+	    lappend errorcode wrongNumArgs
+	    return -code error -errorcode $errorcode \
+		"wrong # args: should be [lrange [info level 0] 0 1]\
+		 ?-option value?... ?--? varname sqlcode ?dictionary? script"
+	}
+	lappend cmd $sqlcode
+
+	# Prepare the statement
+
+	set stmt [uplevel 1 $cmd]
+
+	# Delegate to the statement to iterate over the results
+
+	set cmd [list $stmt foreach {*}$opts -- $varname]
+	if {[info exists dict]} {
+	    lappend cmd $dict
+	}
+	lappend cmd $script
+	set status [catch {
+	    uplevel 1 $cmd
+	} result options]
+
+	# Destroy the statement
+
+	catch {
+	    $stmt close
+	}
+
+	# Adjust return level in the case that the script [return]s
+
+	if {$status == 2} {
+	    set options [dict merge {-level 1} $options[set options {}]]
+	    dict incr options -level
+	}
+	return -options $options $result
+    }
+
+    # The 'BuildPrimaryKeysStatement' method builds a SQL statement to
+    # retrieve the primary keys from a database. (It executes once the
+    # first time the 'primaryKeys' method is executed, and retains the
+    # prepared statement for reuse.)
+
+    method BuildPrimaryKeysStatement {} {
+
+	# On some databases, CONSTRAINT_CATALOG is always NULL and
+	# JOINing to it fails. Check for this case and include that
+	# JOIN only if catalog names are supplied.
+
+	set catalogClause {}
+	if {[lindex [set count [my allrows -as lists {
+	    SELECT COUNT(*)
+	    FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS
+	    WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} {
+	    set catalogClause \
+		{AND xtable.CONSTRAINT_CATALOG = xcolumn.CONSTRAINT_CATALOG}
+	}
+	set primaryKeysStatement [my prepare "
+	     SELECT xtable.TABLE_SCHEMA AS \"tableSchema\",
+		 xtable.TABLE_NAME AS \"tableName\",
+		 xtable.CONSTRAINT_CATALOG AS \"constraintCatalog\",
+		 xtable.CONSTRAINT_SCHEMA AS \"constraintSchema\",
+		 xtable.CONSTRAINT_NAME AS \"constraintName\",
+		 xcolumn.COLUMN_NAME AS \"columnName\",
+		 xcolumn.ORDINAL_POSITION AS \"ordinalPosition\"
+	     FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS xtable
+	     INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE xcolumn
+		     ON xtable.CONSTRAINT_SCHEMA = xcolumn.CONSTRAINT_SCHEMA
+		    AND xtable.TABLE_NAME = xcolumn.TABLE_NAME
+		    AND xtable.CONSTRAINT_NAME = xcolumn.CONSTRAINT_NAME
+		    $catalogClause
+	     WHERE xtable.TABLE_NAME = :tableName
+	       AND xtable.CONSTRAINT_TYPE = 'PRIMARY KEY'
+  	"]
+    }
+
+    # The default implementation of the 'primarykeys' method uses the
+    # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases
+    # that might not have INFORMATION_SCHEMA must overload this method.
+
+    method primarykeys {tableName} {
+	if {![info exists primaryKeysStatement]} {
+	    my BuildPrimaryKeysStatement
+	}
+	tailcall $primaryKeysStatement allrows [list tableName $tableName]
+    }
+
+    # The 'BuildForeignKeysStatements' method builds a SQL statement to
+    # retrieve the foreign keys from a database. (It executes once the
+    # first time the 'foreignKeys' method is executed, and retains the
+    # prepared statements for reuse.)
+
+    method BuildForeignKeysStatement {} {
+
+	# On some databases, CONSTRAINT_CATALOG is always NULL and
+	# JOINing to it fails. Check for this case and include that
+	# JOIN only if catalog names are supplied.
+
+	set catalogClause1 {}
+	set catalogClause2 {}
+	if {[lindex [set count [my allrows -as lists {
+	    SELECT COUNT(*)
+	    FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS
+	    WHERE CONSTRAINT_CATALOG IS NOT NULL}]] 0 0] != 0} {
+	    set catalogClause1 \
+		{AND fkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG}
+	    set catalogClause2 \
+		{AND pkc.CONSTRAINT_CATALOG = rc.CONSTRAINT_CATALOG}
+	}
+
+	foreach {exists1 clause1} {
+	    0 {}
+	    1 { AND pkc.TABLE_NAME = :primary}
+	} {
+	    foreach {exists2 clause2} {
+		0 {}
+		1 { AND fkc.TABLE_NAME = :foreign}
+	    } {
+		set stmt [my prepare "
+	     SELECT rc.CONSTRAINT_CATALOG AS \"foreignConstraintCatalog\",
+		    rc.CONSTRAINT_SCHEMA AS \"foreignConstraintSchema\",
+		    rc.CONSTRAINT_NAME AS \"foreignConstraintName\",
+		    rc.UNIQUE_CONSTRAINT_CATALOG
+			AS \"primaryConstraintCatalog\",
+		    rc.UNIQUE_CONSTRAINT_SCHEMA AS \"primaryConstraintSchema\",
+		    rc.UNIQUE_CONSTRAINT_NAME AS \"primaryConstraintName\",
+		    rc.UPDATE_RULE AS \"updateAction\",
+		    rc.DELETE_RULE AS \"deleteAction\",
+		    pkc.TABLE_CATALOG AS \"primaryCatalog\",
+		    pkc.TABLE_SCHEMA AS \"primarySchema\",
+		    pkc.TABLE_NAME AS \"primaryTable\",
+		    pkc.COLUMN_NAME AS \"primaryColumn\",
+		    fkc.TABLE_CATALOG AS \"foreignCatalog\",
+		    fkc.TABLE_SCHEMA AS \"foreignSchema\",
+		    fkc.TABLE_NAME AS \"foreignTable\",
+		    fkc.COLUMN_NAME AS \"foreignColumn\",
+		    pkc.ORDINAL_POSITION AS \"ordinalPosition\"
+	     FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
+	     INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fkc
+		     ON fkc.CONSTRAINT_NAME = rc.CONSTRAINT_NAME
+		    AND fkc.CONSTRAINT_SCHEMA = rc.CONSTRAINT_SCHEMA
+		    $catalogClause1
+	     INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE pkc
+		     ON pkc.CONSTRAINT_NAME = rc.UNIQUE_CONSTRAINT_NAME
+		     AND pkc.CONSTRAINT_SCHEMA = rc.UNIQUE_CONSTRAINT_SCHEMA
+		     $catalogClause2
+		     AND pkc.ORDINAL_POSITION = fkc.ORDINAL_POSITION
+	     WHERE 1=1
+		 $clause1
+		 $clause2
+	     ORDER BY \"foreignConstraintCatalog\", \"foreignConstraintSchema\", \"foreignConstraintName\", \"ordinalPosition\"
+"]
+		dict set foreignKeysStatement $exists1 $exists2 $stmt
+	    }
+	}
+    }
+
+    # The default implementation of the 'foreignkeys' method uses the
+    # SQL INFORMATION_SCHEMA to retrieve primary key information. Databases
+    # that might not have INFORMATION_SCHEMA must overload this method.
+
+    method foreignkeys {args} {
+
+	variable ::tdbc::generalError
+
+	# Check arguments
+
+	set argdict {}
+	if {[llength $args] % 2 != 0} {
+	    set errorcode $generalError
+	    lappend errorcode wrongNumArgs
+	    return -code error -errorcode $errorcode \
+		"wrong # args: should be [lrange [info level 0] 0 1]\
+		 ?-option value?..."
+	}
+	foreach {key value} $args {
+	    if {$key ni {-primary -foreign}} {
+		set errorcode $generalError
+		lappend errorcode badOption
+		return -code error -errorcode $errorcode \
+		    "bad option \"$key\", must be -primary or -foreign"
+	    }
+	    set key [string range $key 1 end]
+	    if {[dict exists $argdict $key]} {
+		set errorcode $generalError
+		lappend errorcode dupOption
+		return -code error -errorcode $errorcode \
+		    "duplicate option \"$key\" supplied"
+	    }
+	    dict set argdict $key $value
+	}
+
+	# Build the statements that query foreign keys. There are four
+	# of them, one for each combination of whether -primary
+	# and -foreign is specified.
+
+	if {![info exists foreignKeysStatement]} {
+	    my BuildForeignKeysStatement
+	}
+	set stmt [dict get $foreignKeysStatement \
+		      [dict exists $argdict primary] \
+		      [dict exists $argdict foreign]]
+	tailcall $stmt allrows $argdict
+    }
+
+    # Derived classes are expected to implement the 'begintransaction',
+    # 'commit', and 'rollback' methods.
+
+    # Derived classes are expected to implement 'tables' and 'columns' method.
+
+}
+
+#------------------------------------------------------------------------------
+#
+# Class: tdbc::statement
+#
+#	Class that represents a SQL statement in a generic database
+#
+#------------------------------------------------------------------------------
+
+oo::class create tdbc::statement {
+
+    # resultSetSeq is the sequence number of the last result set created.
+    # resultSetClass is the name of the class that implements the 'resultset'
+    #	API.
+
+    variable resultSetClass resultSetSeq
+
+    # The base class constructor accepts no arguments.  It initializes
+    # the machinery for tracking the ownership of result sets. The derived
+    # constructor is expected to invoke the base constructor, and to
+    # set a variable 'resultSetClass' to the fully-qualified name of the
+    # class that represents result sets.
+
+    constructor {} {
+	set resultSetSeq 0
+	namespace eval ResultSet {}
+    }
+
+    # The 'execute' method on a statement runs the statement with
+    # a particular set of substituted variables.  It actually works
+    # by creating the result set object and letting that objects
+    # constructor do the work of running the statement.  The creation
+    # is wrapped in an [uplevel] call because the substitution proces
+    # may need to access variables in the caller's scope.
+
+    # WORKAROUND: Take out the '0 &&' from the next line when
+    # Bug 2649975 is fixed
+    if {0 && [package vsatisfies [package provide Tcl] 8.6]} {
+	method execute args {
+	    tailcall my resultSetCreate \
+		[namespace current]::ResultSet::[incr resultSetSeq]  \
+		[self] {*}$args
+	}
+    } else {
+	method execute args {
+	    return \
+		[uplevel 1 \
+		     [list \
+			  [self] resultSetCreate \
+			  [namespace current]::ResultSet::[incr resultSetSeq] \
+			  [self] {*}$args]]
+	}
+    }
+
+    # The 'ResultSetCreate' method is expected to be a forward to the
+    # appropriate result set constructor. If it's missing, the driver must
+    # have been designed for tdbc 1.0b9 and earlier, and the 'resultSetClass'
+    # variable holds the class name.
+
+    method resultSetCreate {name instance args} {
+	return [uplevel 1 [list $resultSetClass create \
+			       $name $instance {*}$args]]
+    }
+
+    # The 'resultsets' method returns a list of result sets produced by
+    # the current statement
+
+    method resultsets {} {
+	info commands ResultSet::*
+    }
+
+    # The 'allrows' method executes a statement with a given set of
+    # substituents, and returns a list of all the rows that the statement
+    # returns.  Optionally, it stores the names of columns in
+    # '-columnsvariable'.
+    #
+    # Usage:
+    #	$statement allrows ?-as lists|dicts? ?-columnsvariable varName? ?--?
+    #		?dictionary?
+
+
+    method allrows args {
+
+	variable ::tdbc::generalError
+
+	# Grab keyword-value parameters
+
+	set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+	# Check postitional parameters
+
+	set cmd [list [self] execute]
+	if {[llength $args] == 0} {
+	    # do nothing
+	} elseif {[llength $args] == 1} {
+	    lappend cmd [lindex $args 0]
+	} else {
+	    set errorcode $generalError
+	    lappend errorcode wrongNumArgs
+	    return -code error -errorcode $errorcode \
+		"wrong # args: should be [lrange [info level 0] 0 1]\
+		 ?-option value?... ?--? ?dictionary?"
+	}
+
+	# Get the result set
+
+	set resultSet [uplevel 1 $cmd]
+
+	# Delegate to the result set's [allrows] method to accumulate
+	# the rows of the result.
+
+	set cmd [list $resultSet allrows {*}$opts]
+	set status [catch {
+	    uplevel 1 $cmd
+	} result options]
+
+	# Destroy the result set
+
+	catch {
+	    rename $resultSet {}
+	}
+
+	# Adjust return level in the case that the script [return]s
+
+	if {$status == 2} {
+	    set options [dict merge {-level 1} $options[set options {}]]
+	    dict incr options -level
+	}
+	return -options $options $result
+    }
+
+    # The 'foreach' method executes a statement with a given set of
+    # substituents.  It runs the supplied script, substituting the supplied
+    # named variable. Optionally, it stores the names of columns in
+    # '-columnsvariable'.
+    #
+    # Usage:
+    #	$statement foreach ?-as lists|dicts? ?-columnsvariable varName? ?--?
+    #		variableName ?dictionary? script
+
+    method foreach args {
+
+	variable ::tdbc::generalError
+
+	# Grab keyword-value parameters
+
+	set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+	# Check positional parameters
+
+	set cmd [list [self] execute]
+	if {[llength $args] == 2} {
+	    lassign $args varname script
+	} elseif {[llength $args] == 3} {
+	    lassign $args varname dict script
+	    lappend cmd $dict
+	} else {
+	    set errorcode $generalError
+	    lappend errorcode wrongNumArgs
+	    return -code error -errorcode $errorcode \
+		"wrong # args: should be [lrange [info level 0] 0 1]\
+		 ?-option value?... ?--? varName ?dictionary? script"
+	}
+
+	# Get the result set
+
+	set resultSet [uplevel 1 $cmd]
+
+	# Delegate to the result set's [foreach] method to evaluate
+	# the script for each row of the result.
+
+	set cmd [list $resultSet foreach {*}$opts -- $varname $script]
+	set status [catch {
+	    uplevel 1 $cmd
+	} result options]
+
+	# Destroy the result set
+
+	catch {
+	    rename $resultSet {}
+	}
+
+	# Adjust return level in the case that the script [return]s
+
+	if {$status == 2} {
+	    set options [dict merge {-level 1} $options[set options {}]]
+	    dict incr options -level
+	}
+	return -options $options $result
+    }
+
+    # The 'close' method is syntactic sugar for invoking the destructor
+
+    method close {} {
+	my destroy
+    }
+
+    # Derived classes are expected to implement their own constructors,
+    # plus the following methods:
+
+    # paramtype paramName ?direction? type ?scale ?precision??
+    #     Declares the type of a parameter in the statement
+
+}
+
+#------------------------------------------------------------------------------
+#
+# Class: tdbc::resultset
+#
+#	Class that represents a result set in a generic database.
+#
+#------------------------------------------------------------------------------
+
+oo::class create tdbc::resultset {
+
+    constructor {} { }
+
+    # The 'allrows' method returns a list of all rows that a given
+    # result set returns.
+
+    method allrows args {
+
+	variable ::tdbc::generalError
+
+	# Parse args
+
+	set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+	if {[llength $args] != 0} {
+	    set errorcode $generalError
+	    lappend errorcode wrongNumArgs
+	    return -code error -errorcode $errorcode \
+		"wrong # args: should be [lrange [info level 0] 0 1]\
+		 ?-option value?... ?--? varName script"
+	}
+
+	# Do -columnsvariable if requested
+
+	if {[dict exists $opts -columnsvariable]} {
+	    upvar 1 [dict get $opts -columnsvariable] columns
+	}
+
+	# Assemble the results
+
+	if {[dict get $opts -as] eq {lists}} {
+	    set delegate nextlist
+	} else {
+	    set delegate nextdict
+	}
+	set results [list]
+	while {1} {
+	    set columns [my columns]
+	    while {[my $delegate row]} {
+		lappend results $row
+	    }
+	    if {![my nextresults]} break
+	}
+	return $results
+
+    }
+
+    # The 'foreach' method runs a script on each row from a result set.
+
+    method foreach args {
+
+	variable ::tdbc::generalError
+
+	# Grab keyword-value parameters
+
+	set args [::tdbc::ParseConvenienceArgs $args[set args {}] opts]
+
+	# Check positional parameters
+
+	if {[llength $args] != 2} {
+	    set errorcode $generalError
+	    lappend errorcode wrongNumArgs
+	    return -code error -errorcode $errorcode \
+		"wrong # args: should be [lrange [info level 0] 0 1]\
+		 ?-option value?... ?--? varName script"
+	}
+
+	# Do -columnsvariable if requested
+
+	if {[dict exists $opts -columnsvariable]} {
+	    upvar 1 [dict get $opts -columnsvariable] columns
+	}
+
+	# Iterate over the groups of results
+	while {1} {
+
+	    # Export column names to caller
+
+	    set columns [my columns]
+
+	    # Iterate over the rows of one group of results
+
+	    upvar 1 [lindex $args 0] row
+	    if {[dict get $opts -as] eq {lists}} {
+		set delegate nextlist
+	    } else {
+		set delegate nextdict
+	    }
+	    while {[my $delegate row]} {
+		set status [catch {
+		    uplevel 1 [lindex $args 1]
+		} result options]
+		switch -exact -- $status {
+		    0 - 4 {	# OK or CONTINUE
+		    }
+		    2 {		# RETURN
+			set options \
+			    [dict merge {-level 1} $options[set options {}]]
+			dict incr options -level
+			return -options $options $result
+		    }
+		    3 {		# BREAK
+			set broken 1
+			break
+		    }
+		    default {	# ERROR or unknown status
+			return -options $options $result
+		    }
+		}
+	    }
+
+	    # Advance to the next group of results if there is one
+
+	    if {[info exists broken] || ![my nextresults]} {
+		break
+	    }
+	}
+
+	return
+    }
+
+
+    # The 'nextrow' method retrieves a row in the form of either
+    # a list or a dictionary.
+
+    method nextrow {args} {
+
+	variable ::tdbc::generalError
+
+	set opts [dict create -as dicts]
+	set i 0
+
+	# Munch keyword options off the front of the command arguments
+
+	foreach {key value} $args {
+	    if {[string index $key 0] eq {-}} {
+		switch -regexp -- $key {
+		    -as? {
+			dict set opts -as $value
+		    }
+		    -- {
+			incr i
+			break
+		    }
+		    default {
+			set errorcode $generalError
+			lappend errorcode badOption $key
+			return -code error -errorcode $errorcode \
+			    "bad option \"$key\":\
+			     must be -as or -columnsvariable"
+		    }
+		}
+	    } else {
+		break
+	    }
+	    incr i 2
+	}
+
+	set args [lrange $args $i end]
+	if {[llength $args] != 1} {
+	    set errorcode $generalError
+	    lappend errorcode wrongNumArgs
+	    return -code error -errorcode $errorcode \
+		"wrong # args: should be [lrange [info level 0] 0 1]\
+		 ?-option value?... ?--? varName"
+	}
+	upvar 1 [lindex $args 0] row
+	if {[dict get $opts -as] eq {lists}} {
+	    set delegate nextlist
+	} else {
+	    set delegate nextdict
+	}
+	return [my $delegate row]
+    }
+
+    # Derived classes must override 'nextresults' if a single
+    # statement execution can yield multiple sets of results
+
+    method nextresults {} {
+	return 0
+    }
+
+    # Derived classes must override 'outputparams' if statements can
+    # have output parameters.
+
+    method outputparams {} {
+	return {}
+    }
+
+    # The 'close' method is syntactic sugar for destroying the result set.
+
+    method close {} {
+	my destroy
+    }
+
+    # Derived classes are expected to implement the following methods:
+
+    # constructor and destructor.
+    #        Constructor accepts a statement and an optional
+    #        a dictionary of substituted parameters  and
+    #        executes the statement against the database. If
+    #	     the dictionary is not supplied, then the default
+    #	     is to get params from variables in the caller's scope).
+    # columns
+    #     -- Returns a list of the names of the columns in the result.
+    # nextdict variableName
+    #     -- Stores the next row of the result set in the given variable
+    #        in caller's scope, in the form of a dictionary that maps
+    #	     column names to values.
+    # nextlist variableName
+    #     -- Stores the next row of the result set in the given variable
+    #        in caller's scope, in the form of a list of cells.
+    # rowcount
+    #     -- Returns a count of rows affected by the statement, or -1
+    #        if the count of rows has not been determined.
+
+}

src/vfs/punk8win.vfs/lib_tcl8/tdbc1.1.12/tdbcConfig.sh

@@ -0,0 +1,81 @@
+# tdbcConfig.sh --
+#
+# This shell script (for sh) is generated automatically by TDBC's configure
+# script. It will create shell variables for most of the configuration options
+# discovered by the configure script. This script is intended to be included
+# by the configure scripts for TDBC extensions so that they don't have to
+# figure this all out for themselves.
+#
+# The information in this file is specific to a single platform.
+#
+# RCS: @(#) $Id$
+
+# TDBC's version number
+tdbc_VERSION=1.1.12
+TDBC_VERSION=1.1.12
+
+# Name of the TDBC library - may be either a static or shared library
+tdbc_LIB_FILE=tdbc1112.dll
+TDBC_LIB_FILE=tdbc1112.dll
+
+# String to pass to the linker to pick up the TDBC library from its build dir
+tdbc_BUILD_LIB_SPEC="-LC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12 -ltdbc1112"
+TDBC_BUILD_LIB_SPEC="-LC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12 -ltdbc1112"
+
+# String to pass to the linker to pick up the TDBC library from its installed
+# dir.
+tdbc_LIB_SPEC="-LC:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/tdbc1.1.12 -ltdbc1112"
+TDBC_LIB_SPEC="-LC:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/tdbc1.1.12 -ltdbc1112"
+
+# Name of the TBDC stub library
+tdbc_STUB_LIB_FILE="libtdbcstub1112.a"
+TDBC_STUB_LIB_FILE="libtdbcstub1112.a"
+
+# String to pass to the linker to pick up the TDBC stub library from its
+# build directory
+tdbc_BUILD_STUB_LIB_SPEC="-LC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12 -ltdbcstub1112"
+TDBC_BUILD_STUB_LIB_SPEC="-LC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12 -ltdbcstub1112"
+
+# String to pass to the linker to pick up the TDBC stub library from its
+# installed directory
+tdbc_STUB_LIB_SPEC="-LC:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/tdbc1.1.12 -ltdbcstub1112"
+TDBC_STUB_LIB_SPEC="-LC:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/tdbc1.1.12 -ltdbcstub1112"
+
+# Path name of the TDBC stub library in its build directory
+tdbc_BUILD_STUB_LIB_PATH="C:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12/libtdbcstub1112.a"
+TDBC_BUILD_STUB_LIB_PATH="C:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12/libtdbcstub1112.a"
+
+# Path name of the TDBC stub library in its installed directory
+tdbc_STUB_LIB_PATH="C:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/tdbc1.1.12/libtdbcstub1112.a"
+TDBC_STUB_LIB_PATH="C:/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/tdbc1.1.12/libtdbcstub1112.a"
+
+# Location of the top-level source directories from which TDBC was built.
+# This is the directory that contains doc/, generic/ and so on.  If TDBC
+# was compiled in a directory other than the source directory, this still
+# points to the location of the sources, not the location where TDBC was
+# compiled.
+tdbc_SRC_DIR="C:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12"
+TDBC_SRC_DIR="C:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12"
+
+# String to pass to the compiler so that an extension can find installed TDBC
+# headers
+tdbc_INCLUDE_SPEC="-I/C/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/include"
+TDBC_INCLUDE_SPEC="-I/C/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/include"
+
+# String to pass to the compiler so that an extension can find TDBC headers
+# in the source directory
+tdbc_BUILD_INCLUDE_SPEC="-IC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12/generic"
+TDBC_BUILD_INCLUDE_SPEC="-IC:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12/generic"
+
+# Path name where .tcl files in the tdbc package appear at run time.
+tdbc_LIBRARY_PATH="/C/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/tdbc1.1.12"
+TDBC_LIBRARY_PATH="/C/bawt/BawtBuild/Windows/x64/Release/Install/Tcl/lib/tdbc1.1.12"
+
+# Path name where .tcl files in the tdbc package appear at build time.
+tdbc_BUILD_LIBRARY_PATH="C:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12/library"
+TDBC_BUILD_LIBRARY_PATH="C:/bawt/BawtBuild/Windows/x64/Release/Build/Tcl/pkgs/tdbc1.1.12/library"
+
+# Additional flags that must be passed to the C compiler to use tdbc
+tdbc_CFLAGS=
+TDBC_CFLAGS=
+

src/vfs/punk8win.vfs/lib_tcl8/tdbcmysql1.1.12/pkgIndex.tcl

@@ -0,0 +1,14 @@
+# Index file to load the TDBC MySQL package.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+    return
+}
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+    package ifneeded tdbc::mysql 1.1.12 \
+	    "[list source -encoding utf-8 [file join $dir tdbcmysql.tcl]]\;\
+	    [list load [file join $dir tcl9tdbcmysql1112.dll] [string totitle tdbcmysql]]"
+} else {
+    package ifneeded tdbc::mysql 1.1.12 \
+	    "[list source -encoding utf-8 [file join $dir tdbcmysql.tcl]]\;\
+	    [list load [file join $dir tdbcmysql1112.dll] [string totitle tdbcmysql]]"
+}

src/vfs/punk8win.vfs/lib_tcl8/tdbcmysql1.1.12/tdbcmysql.tcl

@@ -100,23 +100,23 @@ package require tdbc
 	    } {
 		set stmt [my prepare "
 	     SELECT rc.CONSTRAINT_SCHEMA AS \"foreignConstraintSchema\",
-                    rc.CONSTRAINT_NAME AS \"foreignConstraintName\",
-                    rc.UPDATE_RULE AS \"updateAction\",
+		    rc.CONSTRAINT_NAME AS \"foreignConstraintName\",
+		    rc.UPDATE_RULE AS \"updateAction\",
 		    rc.DELETE_RULE AS \"deleteAction\",
 		    fkc.REFERENCED_TABLE_SCHEMA AS \"primarySchema\",
-                    fkc.REFERENCED_TABLE_NAME AS \"primaryTable\",
-                    fkc.REFERENCED_COLUMN_NAME AS \"primaryColumn\",
-                    fkc.TABLE_SCHEMA AS \"foreignSchema\",
-                    fkc.TABLE_NAME AS \"foreignTable\",
-                    fkc.COLUMN_NAME AS \"foreignColumn\",
-                    fkc.ORDINAL_POSITION AS \"ordinalPosition\"
-             FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
-             INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fkc
-                     ON fkc.CONSTRAINT_NAME = rc.CONSTRAINT_NAME
-                    AND fkc.CONSTRAINT_SCHEMA = rc.CONSTRAINT_SCHEMA
-             WHERE 1=1
-                 $clause1
-                 $clause2
+		    fkc.REFERENCED_TABLE_NAME AS \"primaryTable\",
+		    fkc.REFERENCED_COLUMN_NAME AS \"primaryColumn\",
+		    fkc.TABLE_SCHEMA AS \"foreignSchema\",
+		    fkc.TABLE_NAME AS \"foreignTable\",
+		    fkc.COLUMN_NAME AS \"foreignColumn\",
+		    fkc.ORDINAL_POSITION AS \"ordinalPosition\"
+	     FROM INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
+	     INNER JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fkc
+		     ON fkc.CONSTRAINT_NAME = rc.CONSTRAINT_NAME
+		    AND fkc.CONSTRAINT_SCHEMA = rc.CONSTRAINT_SCHEMA
+	     WHERE 1=1
+		 $clause1
+		 $clause2
 "]
 		dict set foreignKeysStatement $exists1 $exists2 $stmt
 	    }

src/vfs/punk8win.vfs/lib_tcl8/tdbcmysql1.1.5/pkgIndex.tcl

@@ -1,14 +0,0 @@
-# Index file to load the TDBC MySQL package.
-
-if {![package vsatisfies [package provide Tcl] 8.6-]} {
-    return
-}
-if {[package vsatisfies [package provide Tcl] 9.0-]} {
-    package ifneeded tdbc::mysql 1.1.5 \
-	    "[list source [file join $dir tdbcmysql.tcl]]\;\
-	    [list load [file join $dir tcl9tdbcmysql115.dll] [string totitle tdbcmysql]]"
-} else {
-    package ifneeded tdbc::mysql 1.1.5 \
-	    "[list source [file join $dir tdbcmysql.tcl]]\;\
-	    [list load [file join $dir tdbcmysql115.dll] [string totitle tdbcmysql]]"
-}

src/vfs/punk8win.vfs/lib_tcl8/tdbcodbc1.1.12/pkgIndex.tcl

@@ -0,0 +1,14 @@
+# Index file to load the TDBC ODBC package.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+    return
+}
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+    package ifneeded tdbc::odbc 1.1.12 \
+	    "[list source -encoding utf-8 [file join $dir tdbcodbc.tcl]]\;\
+	    [list load [file join $dir tcl9tdbcodbc1112.dll] [string totitle tdbcodbc]]"
+} else {
+    package ifneeded tdbc::odbc 1.1.12 \
+	    "[list source -encoding utf-8 [file join $dir tdbcodbc.tcl]]\;\
+	    [list load [file join $dir tdbcodbc1112.dll] [string totitle tdbcodbc]]"
+}

src/vfs/punk8win.vfs/lib_tcl8/tdbcodbc1.1.12/tdbcodbc.tcl

@@ -270,7 +270,7 @@ package require tdbc
 
 	# at least if making all parameters 'inout' doesn't work.
 
-        }
+	}
 
     }
 

src/vfs/punk8win.vfs/lib_tcl8/tdbcodbc1.1.5/pkgIndex.tcl

@@ -1,14 +0,0 @@
-# Index file to load the TDBC ODBC package.
-
-if {![package vsatisfies [package provide Tcl] 8.6-]} {
-    return
-}
-if {[package vsatisfies [package provide Tcl] 9.0-]} {
-    package ifneeded tdbc::odbc 1.1.5 \
-	    "[list source [file join $dir tdbcodbc.tcl]]\;\
-	    [list load [file join $dir tcl9tdbcodbc115.dll] [string totitle tdbcodbc]]"
-} else {
-    package ifneeded tdbc::odbc 1.1.5 \
-	    "[list source [file join $dir tdbcodbc.tcl]]\;\
-	    [list load [file join $dir tdbcodbc115.dll] [string totitle tdbcodbc]]"
-}

src/vfs/punk8win.vfs/lib_tcl8/tdbcpostgres1.1.12/pkgIndex.tcl

@@ -0,0 +1,14 @@
+# Index file to load the TDBC Postgres package.
+
+if {![package vsatisfies [package provide Tcl] 8.6-]} {
+    return
+}
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+    package ifneeded tdbc::postgres 1.1.12 \
+	    "[list source -encoding utf-8 [file join $dir tdbcpostgres.tcl]]\;\
+	    [list load [file join $dir tcl9tdbcpostgres1112.dll] [string totitle tdbcpostgres]]"
+} else {
+    package ifneeded tdbc::postgres 1.1.12 \
+	    "[list source -encoding utf-8 [file join $dir tdbcpostgres.tcl]]\;\
+	    [list load [file join $dir tdbcpostgres1112.dll] [string totitle tdbcpostgres]]"
+}

src/vfs/punk8win.vfs/lib_tcl8/tdbcpostgres1.1.5/pkgIndex.tcl

@@ -1,14 +0,0 @@
-# Index file to load the TDBC Postgres package.
-
-if {![package vsatisfies [package provide Tcl] 8.6-]} {
-    return
-}
-if {[package vsatisfies [package provide Tcl] 9.0-]} {
-    package ifneeded tdbc::postgres 1.1.5 \
-	    "[list source [file join $dir tdbcpostgres.tcl]]\;\
-	    [list load [file join $dir tcl9tdbcpostgres115.dll] [string totitle tdbcpostgres]]"
-} else {
-    package ifneeded tdbc::postgres 1.1.5 \
-	    "[list source [file join $dir tdbcpostgres.tcl]]\;\
-	    [list load [file join $dir tdbcpostgres115.dll] [string totitle tdbcpostgres]]"
-}

src/vfs/punk8win.vfs/lib_tcl8/tdom0.9.3/pkgIndex.tcl

@@ -1,6 +0,0 @@
-#
-# Tcl package index file
-#
-package ifneeded tdom 0.9.3 \
-    "[list load [file join $dir tdom093.dll]];
-     [list source [file join $dir tdom.tcl]]"

src/vfs/punk8win.vfs/lib_tcl8/tdom0.9.6/pkgIndex.tcl

@@ -0,0 +1,12 @@
+#
+# Tcl package index file
+#
+if {[package vsatisfies [package provide Tcl] 9.0-]} {
+    package ifneeded tdom 0.9.6 \
+        "[list load [file join $dir tcl9tdom096.dll]];
+         [list source [file join $dir tdom.tcl]]"
+} else {
+    package ifneeded tdom 0.9.6 \
+        "[list load [file join $dir tdom096.dll]];
+         [list source [file join $dir tdom.tcl]]"
+}

src/vfs/punk8win.vfs/lib_tcl8/tdom0.9.6/tdom.tcl

@@ -54,6 +54,7 @@ namespace eval ::dom {
 namespace eval ::tdom { 
     variable extRefHandlerDebug 0
     variable useForeignDTD ""
+    variable utf8bom 0
 
     namespace export xmlOpenFile xmlReadFile xmlReadFileForSimple \
         extRefHandler baseURL
@@ -429,7 +430,7 @@ proc ::dom::domNode::substringData { node offset count } {
     } {
         return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
     }
-    set endOffset [expr $offset + $count - 1]
+    set endOffset {[expr $offset + $count - 1]}
     return [string range [$node nodeValue] $offset $endOffset]
 }
 
@@ -740,13 +741,19 @@ proc ::tdom::IANAEncoding2TclEncoding {IANAName} {
 #
 #----------------------------------------------------------------------------
 proc ::tdom::xmlOpenFileWorker {filename {encodingString {}} {forSimple 0} {forRead 0}} {
-
+    variable utf8bom
+    
     # This partly (mis-)use the encoding of a channel handed to [dom
     # parse -channel ..] as a marker: if the channel encoding is utf-8
     # then behind the scene Tcl_Read() is used, otherwise
     # Tcl_ReadChars(). This is used for the encodings understood (and
     # checked) by the used expat implementation: utf-8 and utf-16 (in
     # either byte order).
+    #
+    # The -translation auto used used in the fconfigure commands which
+    # set the encoding isn't strictly necessary in case the parser is
+    # expat (because it handles that internally) but it is the right
+    # thing for the simple parser.
     
     set fd [open $filename]
 
@@ -757,9 +764,11 @@ proc ::tdom::xmlOpenFileWorker {filename {encodingString {}} {forSimple 0} {forR
     # The autodetection of the encoding follows
     # XML Recomendation, Appendix F
 
-    fconfigure $fd -encoding binary
+    fconfigure $fd -translation binary
     if {![binary scan [read $fd 4] "H8" firstBytes]} {
-        # very short (< 4 Bytes) file
+        # very short (< 4 Bytes) file, that means not a well-formed
+        # XML at all (the shortes possible would be <[a-zA-Z]/>).
+        # Don't report that here but let the parser do that.
         seek $fd 0 start
         set encString UTF-8
         return $fd
@@ -770,11 +779,17 @@ proc ::tdom::xmlOpenFileWorker {filename {encodingString {}} {forSimple 0} {forR
         "feff" {
             # feff: UTF-16, big-endian BOM
             if {$forSimple || $forRead} {
-                error "UTF-16be is not supported"
+                if {[package vsatisfies [package provide Tcl] 9-]} {
+                    seek $fd 2 start
+                    fconfigure $fd -encoding utf-16be -translation auto
+                } else {
+                    error "UTF-16be is not supported"
+                }
+            } else {
+                seek $fd 0 start
+                set encString UTF-16be
+                fconfigure $fd -encoding utf-8 -translation auto
             }
-            seek $fd 0 start
-            set encString UTF-16be
-            fconfigure $fd -encoding utf-8
             return $fd
         }
         "fffe" {
@@ -782,15 +797,33 @@ proc ::tdom::xmlOpenFileWorker {filename {encodingString {}} {forSimple 0} {forR
             set encString UTF-16le          
             if {$forSimple || $forRead} {
                 seek $fd 2 start
-                fconfigure $fd -encoding unicode
+                if {[package vsatisfies [package provide Tcl] 9-]} {
+                    fconfigure $fd -encoding utf-16le -translation auto
+                } else {
+                    fconfigure $fd -encoding unicode -translation auto
+                }
             } else {
                 seek $fd 0 start
-                fconfigure $fd -encoding utf-8
+                fconfigure $fd -encoding utf-8 -translation auto
             }
             return $fd
         }
     }
     
+    if {$utf8bom} {
+        # According to the Unicode standard
+        # (http://www.unicode.org/versions/Unicode5.0.0/ch02.pdf) the
+        # "[u]se of a BOM is neither required nor recommended for
+        # UTF-8". Nevertheless such files exits. If the programmer
+        # explcitely enables this by setting ::tdom::utf8bom to true
+        # this is handled here.
+        if {[string range $firstBytes 0 5] eq "efbbbf"} {
+            set encString UTF-8
+            seek $fd 3 start
+            fconfigure $fd -encoding utf-8 -translation auto
+            return $fd
+        }
+    }
     
     # If the entity has a XML Declaration, the first four characters
     # must be "<?xm".
@@ -838,27 +871,40 @@ proc ::tdom::xmlOpenFileWorker {filename {encodingString {}} {forSimple 0} {forR
         }
             "003c003f" {
             # UTF-16, big-endian, no BOM
-            if {$forSimple} {
-                error "UTF-16be is not supported by the simple parser"
+            if {$forSimple || $forRead} {
+                if {[package vsatisfies [package provide Tcl] 9-]} {
+                    set encoding utf-16be
+                } else {
+                    error "UTF-16be is not supported by the simple parser"
+                }
+            } else {
+                set encoding utf-8
             }
             seek $fd 0 start
-            set encoding utf-8
             set encString UTF-16be
         }
         "3c003f00" {
             # UTF-16, little-endian, no BOM
-            if {$forSimple} {
-                seek $fd 2 start
-                set encoding unicode
+            if {$forSimple || $forRead} {
+                if {[package vsatisfies [package provide Tcl] 9-]} {
+                    set encoding utf-16le
+                } else {
+                    set encoding unicode
+                }
             } else {
-                seek $fd 0 start
                 set encoding utf-8
             }
+            seek $fd 0 start
             set encString UTF-16le          
         }
         "4c6fa794" {
             # EBCDIC in some flavor
-            error "EBCDIC not supported"
+            if {[package vsatisfies [package provide Tcl] 9-]} {
+                seek $fd 0 start
+                set encoding ebcdic
+            } else {
+                error "EBCDIC not supported"
+            }
         }
         default {
             # UTF-8 without an encoding declaration
@@ -867,7 +913,7 @@ proc ::tdom::xmlOpenFileWorker {filename {encodingString {}} {forSimple 0} {forR
             set encString "UTF-8"
         }
     }
-    fconfigure $fd -encoding $encoding
+    fconfigure $fd -encoding $encoding -translation auto
     return $fd
 }
 
@@ -992,6 +1038,47 @@ proc ::tdom::baseURL {path} {
     }
 }
 
+namespace eval ::tdom::json {
+    namespace export asDict
+}
+
+# The argument node may be an element node as well as a document node.
+proc ::tdom::json::asDict {node} {
+    return [nodesAsDict [$node childNodes] [$node jsonType]]
+}
+
+proc ::tdom::json::nodesAsDict {nodes parentType} {
+    set result ""
+    foreach n $nodes {
+        set children [$n childNodes]
+        set jsonType [$n jsonType]
+        set childrendValue [nodesAsDict $children $jsonType]
+
+        switch $jsonType {
+            OBJECT {
+                if {[$n nodeName] ne "objectcontainer" || $parentType eq "OBJECT"} {
+                    lappend result [$n nodeName]
+                }
+                lappend result $childrendValue
+            }
+            NONE {
+                lappend result [$n nodeName] $childrendValue
+            }
+            ARRAY {
+                if {[$n nodeName] ne "arraycontainer" || $parentType eq "OBJECT"} {
+                    lappend result [$n nodeName]
+                }
+                lappend result $childrendValue
+            }
+            default {
+                set op [expr {[llength $nodes] > 1 ? "lappend" : "set"} ]
+                $op result [$n nodeValue]
+            }
+        }
+    }
+    return $result
+}
+
 namespace eval ::tDOM { 
     variable extRefHandlerDebug 0
     variable useForeignDTD ""
@@ -1008,7 +1095,7 @@ foreach ::tdom::cmd {
     baseURL
     IANAEncoding2TclEncoding
 } {
-    interp alias {} tDOM::$::tdom::cmd {} tdom::$::tdom::cmd
+    interp alias {} ::tDOM::$::tdom::cmd {} ::tdom::$::tdom::cmd
 }
 
 # EOF

src/vfs/punk8win.vfs/lib_tcl8/thread2.8.12/pkgIndex.tcl

@@ -0,0 +1,68 @@
+# -*- tcl -*-
+# Tcl package index file, version 1.1
+#
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+    # Pre-8.4 Tcl interps we dont support at all.  Bye!
+    # 9.0+ Tcl interps are only supported on 32-bit platforms.
+    if {![package vsatisfies [package provide Tcl] 9.0]
+	    || ($::tcl_platform(pointerSize) != 4)} {
+	return
+    }
+}
+
+# All Tcl 8.4+ interps can [load] Thread 2.8.12
+#
+# For interps that are not thread-enabled, we still call [package ifneeded].
+# This is contrary to the usual convention, but is a good idea because we
+# cannot imagine any other version of Thread that might succeed in a
+# thread-disabled interp.  There's nothing to gain by yielding to other
+# competing callers of [package ifneeded Thread].  On the other hand,
+# deferring the error has the advantage that a script calling
+# [package require Thread] in a thread-disabled interp gets an error message
+# about a thread-disabled interp, instead of the message
+# "can't find package Thread".
+
+package ifneeded Thread 2.8.12 [list load [file join $dir thread2812.dll] [string totitle thread]]
+
+# package Ttrace uses some support machinery.
+
+# In Tcl 8.4 interps we use some older interfaces
+if {![package vsatisfies [package provide Tcl] 8.5]} {
+    package ifneeded Ttrace 2.8.12 "
+    [list proc thread_source {dir} {
+	if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
+		[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
+	    source -encoding utf-8 $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
+	} elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
+	    source -encoding utf-8 [file join $dir .. lib ttrace.tcl]
+	} elseif {[file readable [file join $dir ttrace.tcl]]} {
+	    source -encoding utf-8 [file join $dir ttrace.tcl]
+	}
+	if {[namespace which ::ttrace::update] ne ""} {
+	    ::ttrace::update
+	}
+    }]
+    [list thread_source $dir]
+    [list rename thread_source {}]"
+    return
+}
+
+# In Tcl 8.5+ interps; use [::apply]
+
+package ifneeded Ttrace 2.8.12 [list ::apply {{dir} {
+    if {[info exists ::env(TCL_THREAD_LIBRARY)] &&
+	[file readable $::env(TCL_THREAD_LIBRARY)/ttrace.tcl]} {
+	source -encoding utf-8 $::env(TCL_THREAD_LIBRARY)/ttrace.tcl
+    } elseif {[file readable [file join $dir .. lib ttrace.tcl]]} {
+	source -encoding utf-8 [file join $dir .. lib ttrace.tcl]
+    } elseif {[file readable [file join $dir ttrace.tcl]]} {
+	source -encoding utf-8 [file join $dir ttrace.tcl]
+    }
+    if {[namespace which ::ttrace::update] ne ""} {
+	::ttrace::update
+    }
+}} $dir]
+
+
+

src/vfs/punk8win.vfs/lib_tcl8/thread2.8.12/ttrace.tcl

@@ -0,0 +1,942 @@
+#
+# ttrace.tcl --
+#
+# Copyright (C) 2003 Zoran Vasiljevic, Archiware GmbH. All Rights Reserved.
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# ----------------------------------------------------------------------------
+#
+# User level commands:
+#
+#   ttrace::eval           top-level wrapper (ttrace-savvy eval)
+#   ttrace::enable         activates registered Tcl command traces
+#   ttrace::disable        terminates tracing of Tcl commands
+#   ttrace::isenabled      returns true if ttrace is enabled
+#   ttrace::cleanup        bring the interp to a pristine state
+#   ttrace::update         update interp to the latest trace epoch
+#   ttrace::config         setup some configuration options
+#   ttrace::getscript      returns a script for initializing interps
+#
+# Commands used for/from trace callbacks:
+#
+#   ttrace::atenable       register callback to be done at trace enable
+#   ttrace::atdisable      register callback to be done at trace disable
+#   ttrace::addtrace       register user-defined tracer callback
+#   ttrace::addscript      register user-defined script generator
+#   ttrace::addresolver    register user-defined command resolver
+#   ttrace::addcleanup     register user-defined cleanup procedures
+#   ttrace::addentry       adds one entry into the named trace store
+#   ttrace::getentry       returns the entry value from the named store
+#   ttrace::delentry       removes the entry from the named store
+#   ttrace::getentries     returns all entries from the named store
+#   ttrace::preload        register procedures to be preloaded always
+#
+#
+# Limitations:
+#
+#   o. [namespace forget] is still not implemented
+#   o. [namespace origin cmd] breaks if cmd is not already defined
+#
+#      I left this deliberately. I didn't want to override the [namespace]
+#      command in order to avoid potential slowdown.
+#
+
+namespace eval ttrace {
+
+    # Setup some compatibility wrappers
+    if {[info commands nsv_set] != ""} {
+	variable tvers 0
+	variable mutex ns_mutex
+	variable elock [$mutex create traceepochmutex]
+	# Import the underlying API; faster than recomputing
+	interp alias {} [namespace current]::_array   {} nsv_array
+	interp alias {} [namespace current]::_incr    {} nsv_incr
+	interp alias {} [namespace current]::_lappend {} nsv_lappend
+	interp alias {} [namespace current]::_names   {} nsv_names
+	interp alias {} [namespace current]::_set     {} nsv_set
+	interp alias {} [namespace current]::_unset   {} nsv_unset
+    } elseif {![catch {
+	variable tvers [package require Thread]
+    }]} {
+	variable mutex thread::mutex
+	variable elock [$mutex create]
+	# Import the underlying API; faster than recomputing
+	interp alias {} [namespace current]::_array   {} tsv::array
+	interp alias {} [namespace current]::_incr    {} tsv::incr
+	interp alias {} [namespace current]::_lappend {} tsv::lappend
+	interp alias {} [namespace current]::_names   {} tsv::names
+	interp alias {} [namespace current]::_set     {} tsv::set
+	interp alias {} [namespace current]::_unset   {} tsv::unset
+    } else {
+	error "requires NaviServer/AOLserver or Tcl threading extension"
+    }
+
+    # Keep in sync with the Thread package
+    package provide Ttrace 2.8.12
+
+    # Package variables
+    variable resolvers ""     ; # List of registered resolvers
+    variable tracers   ""     ; # List of registered cmd tracers
+    variable scripts   ""     ; # List of registered script makers
+    variable enables   ""     ; # List of trace-enable callbacks
+    variable disables  ""     ; # List of trace-disable callbacks
+    variable preloads  ""     ; # List of procedure names to preload
+    variable enabled   0      ; # True if trace is enabled
+    variable config           ; # Array with config options
+
+    variable epoch     -1     ; # The initialization epoch
+    variable cleancnt   0     ; # Counter of registered cleaners
+
+    # Package private namespaces
+    namespace eval resolve "" ; # Commands for resolving commands
+    namespace eval trace   "" ; # Commands registered for tracing
+    namespace eval enable  "" ; # Commands invoked at trace enable
+    namespace eval disable "" ; # Commands invoked at trace disable
+    namespace eval script  "" ; # Commands for generating scripts
+
+    # Exported commands
+    namespace export unknown
+
+    # Initialize ttrace shared state
+    if {[_array exists ttrace] == 0} {
+	_set ttrace lastepoch $epoch
+	_set ttrace epochlist ""
+    }
+
+    # Initially, allow creation of epochs
+    set config(-doepochs) 1
+
+    proc eval {cmd args} {
+	enable
+	set code [catch {uplevel 1 [concat $cmd $args]} result]
+	disable
+	if {$code == 0} {
+	    if {[llength [info commands ns_ictl]]} {
+		ns_ictl save [getscript]
+	    } else {
+		thread::broadcast {
+		    package require Ttrace
+		    ttrace::update
+		}
+	    }
+	}
+	return -code $code \
+	    -errorinfo $::errorInfo -errorcode $::errorCode $result
+    }
+
+    proc config {args} {
+	variable config
+	if {[llength $args] == 0} {
+	    array get config
+	} elseif {[llength $args] == 1} {
+	    set opt [lindex $args 0]
+	    set config($opt)
+	} else {
+	    set opt [lindex $args 0]
+	    set val [lindex $args 1]
+	    set config($opt) $val
+	}
+    }
+
+    proc enable {} {
+	variable config
+	variable tracers
+	variable enables
+	variable enabled
+	incr enabled 1
+	if {$enabled > 1} {
+	    return
+	}
+	if {$config(-doepochs) != 0} {
+	    variable epoch [_newepoch]
+	}
+	set nsp [namespace current]
+	foreach enabler $enables {
+	    enable::_$enabler
+	}
+	foreach trace $tracers {
+	    if {[info commands $trace] != ""} {
+		trace add execution $trace leave ${nsp}::trace::_$trace
+	    }
+	}
+    }
+
+    proc disable {} {
+	variable enabled
+	variable tracers
+	variable disables
+	incr enabled -1
+	if {$enabled > 0} {
+	    return
+	}
+	set nsp [namespace current]
+	foreach disabler $disables {
+	    disable::_$disabler
+	}
+	foreach trace $tracers {
+	    if {[info commands $trace] != ""} {
+		trace remove execution $trace leave ${nsp}::trace::_$trace
+	    }
+	}
+    }
+
+    proc isenabled {} {
+	variable enabled
+	expr {$enabled > 0}
+    }
+
+    proc update {{from -1}} {
+	if {$from < 0} {
+	    variable epoch [_set ttrace lastepoch]
+	} else {
+	    if {[lsearch [_set ttrace epochlist] $from] < 0} {
+		error "no such epoch: $from"
+	    }
+	    variable epoch $from
+	}
+	uplevel 1 [getscript]
+    }
+
+    proc getscript {} {
+	variable preloads
+	variable epoch
+	variable scripts
+	append script [_serializensp] \n
+	append script "::namespace eval [namespace current] {" \n
+	append script "::namespace export unknown" \n
+	append script "_useepoch $epoch" \n
+	append script "}" \n
+	foreach cmd $preloads {
+	    append script [_serializeproc $cmd] \n
+	}
+	foreach maker $scripts {
+	    append script [script::_$maker]
+	}
+	return $script
+    }
+
+    proc cleanup {args} {
+	foreach cmd [info commands resolve::cleaner_*] {
+	    uplevel 1 $cmd $args
+	}
+    }
+
+    proc preload {cmd} {
+	variable preloads
+	if {[lsearch $preloads $cmd] < 0} {
+	    lappend preloads $cmd
+	}
+    }
+
+    proc atenable {cmd arglist body} {
+	variable enables
+	if {[lsearch $enables $cmd] < 0} {
+	    lappend enables $cmd
+	    set cmd [namespace current]::enable::_$cmd
+	    proc $cmd $arglist $body
+	    return $cmd
+	}
+    }
+
+    proc atdisable {cmd arglist body} {
+	variable disables
+	if {[lsearch $disables $cmd] < 0} {
+	    lappend disables $cmd
+	    set cmd [namespace current]::disable::_$cmd
+	    proc $cmd $arglist $body
+	    return $cmd
+	}
+    }
+
+    proc addtrace {cmd arglist body} {
+	variable tracers
+	if {[lsearch $tracers $cmd] < 0} {
+	    lappend tracers $cmd
+	    set tracer [namespace current]::trace::_$cmd
+	    proc $tracer $arglist $body
+	    if {[isenabled]} {
+		trace add execution $cmd leave $tracer
+	    }
+	    return $tracer
+	}
+    }
+
+    proc addscript {cmd body} {
+	variable scripts
+	if {[lsearch $scripts $cmd] < 0} {
+	    lappend scripts $cmd
+	    set cmd [namespace current]::script::_$cmd
+	    proc $cmd args $body
+	    return $cmd
+	}
+    }
+
+    proc addresolver {cmd arglist body} {
+	variable resolvers
+	if {[lsearch $resolvers $cmd] < 0} {
+	    lappend resolvers $cmd
+	    set cmd [namespace current]::resolve::$cmd
+	    proc $cmd $arglist $body
+	    return $cmd
+	}
+    }
+
+    proc addcleanup {body} {
+	variable cleancnt
+	set cmd [namespace current]::resolve::cleaner_[incr cleancnt]
+	proc $cmd args $body
+	return $cmd
+    }
+
+    proc addentry {cmd var val} {
+	variable epoch
+	_set ${epoch}-$cmd $var $val
+    }
+
+    proc delentry {cmd var} {
+	variable epoch
+	set ei $::errorInfo
+	set ec $::errorCode
+	catch {_unset ${epoch}-$cmd $var}
+	set ::errorInfo $ei
+	set ::errorCode $ec
+    }
+
+    proc getentry {cmd var} {
+	variable epoch
+	set ei $::errorInfo
+	set ec $::errorCode
+	if {[catch {_set ${epoch}-$cmd $var} val]} {
+	    set ::errorInfo $ei
+	    set ::errorCode $ec
+	    set val ""
+	}
+	return $val
+    }
+
+    proc getentries {cmd {pattern *}} {
+	variable epoch
+	_array names ${epoch}-$cmd $pattern
+    }
+
+    proc unknown {args} {
+	set cmd [lindex $args 0]
+	if {[uplevel 1 ttrace::_resolve [list $cmd]]} {
+	    set c [catch {uplevel 1 $cmd [lrange $args 1 end]} r]
+	} else {
+	    set c [catch {uplevel 1 ::tcl::unknown $args} r]
+	}
+	return -code $c -errorcode $::errorCode -errorinfo $::errorInfo $r
+    }
+
+    proc _resolve {cmd} {
+	variable resolvers
+	foreach resolver $resolvers {
+	    if {[uplevel 1 [info comm resolve::$resolver] [list $cmd]]} {
+		return 1
+	    }
+	}
+	return 0
+    }
+
+    proc _getthread {} {
+	if {[info commands ns_thread] == ""} {
+	    thread::id
+	} else {
+	    ns_thread getid
+	}
+    }
+
+    proc _getthreads {} {
+	if {[info commands ns_thread] == ""} {
+	    return [thread::names]
+	} else {
+	    foreach entry [ns_info threads] {
+		lappend threads [lindex $entry 2]
+	    }
+	    return $threads
+	}
+    }
+
+    proc _newepoch {} {
+	variable elock
+	variable mutex
+	$mutex lock $elock
+	set old [_set ttrace lastepoch]
+	set new [_incr ttrace lastepoch]
+	_lappend ttrace $new [_getthread]
+	if {$old >= 0} {
+	    _copyepoch $old $new
+	    _delepochs
+	}
+	_lappend ttrace epochlist $new
+	$mutex unlock $elock
+	return $new
+    }
+
+    proc _copyepoch {old new} {
+	foreach var [_names $old-*] {
+	    set cmd [lindex [split $var -] 1]
+	    _array reset $new-$cmd [_array get $var]
+	}
+    }
+
+    proc _delepochs {} {
+	set tlist [_getthreads]
+	set elist ""
+	foreach epoch [_set ttrace epochlist] {
+	    if {[_dropepoch $epoch $tlist] == 0} {
+		lappend elist $epoch
+	    } else {
+		_unset ttrace $epoch
+	    }
+	}
+	_set ttrace epochlist $elist
+    }
+
+    proc _dropepoch {epoch threads} {
+	set self [_getthread]
+	foreach tid [_set ttrace $epoch] {
+	    if {$tid != $self && [lsearch $threads $tid] >= 0} {
+		lappend alive $tid
+	    }
+	}
+	if {[info exists alive]} {
+	    _set ttrace $epoch $alive
+	    return 0
+	} else {
+	    foreach var [_names $epoch-*] {
+		_unset $var
+	    }
+	    return 1
+	}
+    }
+
+    proc _useepoch {epoch} {
+	if {$epoch >= 0} {
+	    set tid [_getthread]
+	    if {[lsearch [_set ttrace $epoch] $tid] == -1} {
+		_lappend ttrace $epoch $tid
+	    }
+	}
+    }
+
+    proc _serializeproc {cmd} {
+	set dargs [info args $cmd]
+	set pbody [info body $cmd]
+	set pargs ""
+	foreach arg $dargs {
+	    if {![info default $cmd $arg def]} {
+		lappend pargs $arg
+	    } else {
+		lappend pargs [list $arg $def]
+	    }
+	}
+	set nsp [namespace qual $cmd]
+	if {$nsp == ""} {
+	    set nsp "::"
+	}
+	append res [list ::namespace eval $nsp] " {" \n
+	append res [list ::proc [namespace tail $cmd] $pargs $pbody] \n
+	append res "}" \n
+    }
+
+    proc _serializensp {{nsp ""} {result _}} {
+	upvar $result res
+	if {$nsp == ""} {
+	    set nsp [namespace current]
+	}
+	append res [list ::namespace eval $nsp] " {" \n
+	foreach var [info vars ${nsp}::*] {
+	    set vname [namespace tail $var]
+	    if {[array exists $var] == 0} {
+		append res [list ::variable $vname [set $var]] \n
+	    } else {
+		append res [list ::variable $vname] \n
+		append res [list ::array set $vname [array get $var]] \n
+	    }
+	}
+	foreach cmd [info procs ${nsp}::*] {
+	    append res [_serializeproc $cmd] \n
+	}
+	append res "}" \n
+	foreach nn [namespace children $nsp] {
+	    _serializensp $nn res
+	}
+	return $res
+    }
+}
+
+#
+# The code below is ment to be run once during the application start.  It
+# provides implementation of tracing callbacks for some Tcl commands.  Users
+# can supply their own tracer implementations on-the-fly.
+#
+# The code below will create traces for the following Tcl commands:
+#    "namespace", "variable", "load", "proc" and "rename"
+#
+# Also, the Tcl object extension XOTcl 1.1.0 is handled and all XOTcl related
+# things, like classes and objects are traced (many thanks to Gustaf Neumann
+# from XOTcl for his kind help and support).
+#
+
+eval {
+
+    #
+    # Register the "load" trace. This will create the following key/value pair
+    # in the "load" store:
+    #
+    #  --- key ----              --- value ---
+    #  <path_of_loaded_image>    <name_of_the_init_proc>
+    #
+    # We normally need only the name_of_the_init_proc for being able to load
+    # the package in other interpreters, but we store the path to the image
+    # file as well.
+    #
+
+    ttrace::addtrace load {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set image [lindex $cmdline 1]
+	set initp [lindex $cmdline 2]
+	if {$initp == ""} {
+	    foreach pkg [info loaded] {
+		if {[lindex $pkg 0] == $image} {
+		    set initp [lindex $pkg 1]
+		}
+	    }
+	}
+	ttrace::addentry load $image $initp
+    }
+
+    ttrace::addscript load {
+	append res "\n"
+	foreach entry [ttrace::getentries load] {
+	    set initp [ttrace::getentry load $entry]
+	    append res "::load {} $initp" \n
+	}
+	return $res
+    }
+
+    #
+    # Register the "namespace" trace. This will create the following key/value
+    # entry in "namespace" store:
+    #
+    #  --- key ----                   --- value ---
+    #  ::fully::qualified::namespace  1
+    #
+    # It will also fill the "proc" store for procedures and commands imported
+    # in this namespace with following:
+    #
+    #  --- key ----                   --- value ---
+    #  ::fully::qualified::proc       [list <ns>  "" ""]
+    #
+    # The <ns> is the name of the namespace where the command or procedure is
+    # imported from.
+    #
+
+    ttrace::addtrace namespace {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set nop [lindex $cmdline 1]
+	set cns [uplevel 1 namespace current]
+	if {$cns == "::"} {
+	    set cns ""
+	}
+	switch -glob $nop {
+	    eva* {
+		set nsp [lindex $cmdline 2]
+		if {![string match "::*" $nsp]} {
+		    set nsp ${cns}::$nsp
+		}
+		ttrace::addentry namespace $nsp 1
+	    }
+	    imp* {
+		# - parse import arguments (skip opt "-force")
+		set opts [lrange $cmdline 2 end]
+		if {[string match "-fo*" [lindex $opts 0]]} {
+		    set opts [lrange $cmdline 3 end]
+		}
+		# - register all imported procs and commands
+		foreach opt $opts {
+		    if {![string match "::*" [::namespace qual $opt]]} {
+			set opt ${cns}::$opt
+		    }
+		    # - first import procs
+		    foreach entry [ttrace::getentries proc $opt] {
+			set cmd ${cns}::[::namespace tail $entry]
+			set nsp [::namespace qual $entry]
+			set done($cmd) 1
+			set entry [list 0 $nsp "" ""]
+			ttrace::addentry proc $cmd $entry
+		    }
+
+		    # - then import commands
+		    foreach entry [info commands $opt] {
+			set cmd ${cns}::[::namespace tail $entry]
+			set nsp [::namespace qual $entry]
+			if {[info exists done($cmd)] == 0} {
+			    set entry [list 0 $nsp "" ""]
+			    ttrace::addentry proc $cmd $entry
+			}
+		    }
+		}
+	    }
+	}
+    }
+
+    ttrace::addscript namespace {
+	append res \n
+	foreach entry [ttrace::getentries namespace] {
+	    append res "::namespace eval $entry {}" \n
+	}
+	return $res
+    }
+
+    #
+    # Register the "variable" trace. This will create the following key/value
+    # entry in the "variable" store:
+    #
+    #  --- key ----                   --- value ---
+    #  ::fully::qualified::variable   1
+    #
+    # The variable value itself is ignored at the time of
+    # trace/collection. Instead, we take the real value at the time of script
+    # generation.
+    #
+
+    ttrace::addtrace variable {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set opts [lrange $cmdline 1 end]
+	if {[llength $opts]} {
+	    set cns [uplevel 1 namespace current]
+	    if {$cns == "::"} {
+		set cns ""
+	    }
+	    foreach {var val} $opts {
+		if {![string match "::*" $var]} {
+		    set var ${cns}::$var
+		}
+		ttrace::addentry variable $var 1
+	    }
+	}
+    }
+
+    ttrace::addscript variable {
+	append res \n
+	foreach entry [ttrace::getentries variable] {
+	    set cns [namespace qual $entry]
+	    set var [namespace tail $entry]
+	    append res "::namespace eval $cns {" \n
+	    append res "::variable $var"
+	    if {[array exists $entry]} {
+		append res "\n::array set $var [list [array get $entry]]" \n
+	    } elseif {[info exists $entry]} {
+		append res " [list [set $entry]]" \n
+	    } else {
+		append res \n
+	    }
+	    append res "}" \n
+	}
+	return $res
+    }
+
+
+    #
+    # Register the "rename" trace. It will create the following key/value pair
+    # in "rename" store:
+    #
+    #  --- key ----              --- value ---
+    #  ::fully::qualified::old  ::fully::qualified::new
+    #
+    # The "new" value may be empty, for commands that have been deleted. In
+    # such cases we also remove any traced procedure definitions.
+    #
+
+    ttrace::addtrace rename {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set cns [uplevel 1 namespace current]
+	if {$cns == "::"} {
+	    set cns ""
+	}
+	set old [lindex $cmdline 1]
+	if {![string match "::*" $old]} {
+	    set old ${cns}::$old
+	}
+	set new [lindex $cmdline 2]
+	if {$new != ""} {
+	    if {![string match "::*" $new]} {
+		set new ${cns}::$new
+	    }
+	    ttrace::addentry rename $old $new
+	} else {
+	    ttrace::delentry proc $old
+	}
+    }
+
+    ttrace::addscript rename {
+	append res \n
+	foreach old [ttrace::getentries rename] {
+	    set new [ttrace::getentry rename $old]
+	    append res "::rename $old {$new}" \n
+	}
+	return $res
+    }
+
+    #
+    # Register the "proc" trace. This will create the following key/value pair
+    # in the "proc" store:
+    #
+    #  --- key ----              --- value ---
+    #  ::fully::qualified::proc  [list <epoch> <ns> <arglist> <body>]
+    #
+    # The <epoch> chages anytime one (re)defines a proc.  The <ns> is the
+    # namespace where the command was imported from. If empty, the <arglist>
+    # and <body> will hold the actual procedure definition. See the
+    # "namespace" tracer implementation also.
+    #
+
+    ttrace::addtrace proc {cmdline code args} {
+	if {$code != 0} {
+	    return
+	}
+	set cns [uplevel 1 namespace current]
+	if {$cns == "::"} {
+	    set cns ""
+	}
+	set cmd [lindex $cmdline 1]
+	if {![string match "::*" $cmd]} {
+	    set cmd ${cns}::$cmd
+	}
+	set dargs [info args $cmd]
+	set pbody [info body $cmd]
+	set pargs ""
+	foreach arg $dargs {
+	    if {![info default $cmd $arg def]} {
+		lappend pargs $arg
+	    } else {
+		lappend pargs [list $arg $def]
+	    }
+	}
+	set pdef [ttrace::getentry proc $cmd]
+	if {$pdef == ""} {
+	    set epoch -1 ; # never traced before
+	} else {
+	    set epoch [lindex $pdef 0]
+	}
+	ttrace::addentry proc $cmd [list [incr epoch] "" $pargs $pbody]
+    }
+
+    ttrace::addscript proc {
+	return {
+	    if {[info command ::tcl::unknown] == ""} {
+		rename ::unknown ::tcl::unknown
+		namespace import -force ::ttrace::unknown
+	    }
+	    if {[info command ::tcl::info] == ""} {
+		rename ::info ::tcl::info
+	    }
+	    proc ::info args {
+		set cmd [lindex $args 0]
+		set hit [lsearch -glob {commands procs args default body} $cmd*]
+		if {$hit > 1} {
+		    if {[catch {uplevel 1 ::tcl::info $args}]} {
+			uplevel 1 ttrace::_resolve [list [lindex $args 1]]
+		    }
+		    return [uplevel 1 ::tcl::info $args]
+		}
+		if {$hit == -1} {
+		    return [uplevel 1 ::tcl::info $args]
+		}
+		set cns [uplevel 1 namespace current]
+		if {$cns == "::"} {
+		    set cns ""
+		}
+		set pat [lindex $args 1]
+		if {![string match "::*" $pat]} {
+		    set pat ${cns}::$pat
+		}
+		set fns [ttrace::getentries proc $pat]
+		if {[string match $cmd* commands]} {
+		    set fns [concat $fns [ttrace::getentries xotcl $pat]]
+		}
+		foreach entry $fns {
+		    if {$cns != [namespace qual $entry]} {
+			set lazy($entry) 1
+		    } else {
+			set lazy([namespace tail $entry]) 1
+		    }
+		}
+		foreach entry [uplevel 1 ::tcl::info $args] {
+		    set lazy($entry) 1
+		}
+		array names lazy
+	    }
+	}
+    }
+
+    #
+    # Register procedure resolver. This will try to resolve the command in the
+    # current namespace first, and if not found, in global namespace.  It also
+    # handles commands imported from other namespaces.
+    #
+
+    ttrace::addresolver resolveprocs {cmd {export 0}} {
+	set cns [uplevel 1 namespace current]
+	set name [namespace tail $cmd]
+	if {$cns == "::"} {
+	    set cns ""
+	}
+	if {![string match "::*" $cmd]} {
+	    set ncmd ${cns}::$cmd
+	    set gcmd ::$cmd
+	} else {
+	    set ncmd $cmd
+	    set gcmd $cmd
+	}
+	set pdef [ttrace::getentry proc $ncmd]
+	if {$pdef == ""} {
+	    set pdef [ttrace::getentry proc $gcmd]
+	    if {$pdef == ""} {
+		return 0
+	    }
+	    set cmd $gcmd
+	} else {
+	    set cmd $ncmd
+	}
+	set epoch [lindex $pdef 0]
+	set pnsp  [lindex $pdef 1]
+	if {$pnsp != ""} {
+	    set nsp [namespace qual $cmd]
+	    if {$nsp == ""} {
+		set nsp ::
+	    }
+	    set cmd ${pnsp}::$name
+	    if {[resolveprocs $cmd 1] == 0 && [info commands $cmd] == ""} {
+		return 0
+	    }
+	    namespace eval $nsp "namespace import -force $cmd"
+	} else {
+	    uplevel 0 [list ::proc $cmd [lindex $pdef 2] [lindex $pdef 3]]
+	    if {$export} {
+		set nsp [namespace qual $cmd]
+		if {$nsp == ""} {
+		    set nsp ::
+		}
+		namespace eval $nsp "namespace export $name"
+	    }
+	}
+	variable resolveproc
+	set resolveproc($cmd) $epoch
+	return 1
+    }
+
+    #
+    # For XOTcl, the entire item introspection/tracing is delegated to XOTcl
+    # itself. The xotcl store is filled with this:
+    #
+    #  --- key ----               --- value ---
+    #  ::fully::qualified::item   <body>
+    #
+    # The <body> is the script used to generate the entire item (class,
+    # object). Note that we do not fill in this during code tracing. It is
+    # done during the script generation. In this step, only the placeholder is
+    # set.
+    #
+    # NOTE: we assume all XOTcl commands are imported in global namespace
+    #
+
+    ttrace::atenable XOTclEnabler {args} {
+	if {[info commands ::xotcl::Class] == ""} {
+	    return
+	}
+	if {[info commands ::xotcl::_creator] == ""} {
+	    ::xotcl::Class create ::xotcl::_creator -instproc create {args} {
+		set result [next]
+		if {![string match ::xotcl::_* $result]} {
+		    ttrace::addentry xotcl $result ""
+		}
+		return $result
+	    }
+	}
+	::xotcl::Class instmixin ::xotcl::_creator
+    }
+
+    ttrace::atdisable XOTclDisabler {args} {
+	if {   [info commands ::xotcl::Class] == ""
+	    || [info commands ::xotcl::_creator] == ""} {
+	    return
+	}
+	::xotcl::Class instmixin ""
+	::xotcl::_creator destroy
+    }
+
+    set resolver [ttrace::addresolver resolveclasses {classname} {
+	set cns [uplevel 1 namespace current]
+	set script [ttrace::getentry xotcl $classname]
+	if {$script == ""} {
+	    set name [namespace tail $classname]
+	    if {$cns == "::"} {
+		set script [ttrace::getentry xotcl ::$name]
+	    } else {
+		set script [ttrace::getentry xotcl ${cns}::$name]
+		if {$script == ""} {
+		    set script [ttrace::getentry xotcl ::$name]
+		}
+	    }
+	    if {$script == ""} {
+		return 0
+	    }
+	}
+	uplevel 1 [list namespace eval $cns $script]
+	return 1
+    }]
+
+    ttrace::addscript xotcl [subst -nocommands {
+	if {![catch {Serializer new} ss]} {
+	    foreach entry [ttrace::getentries xotcl] {
+		if {[ttrace::getentry xotcl \$entry] == ""} {
+		    ttrace::addentry xotcl \$entry [\$ss serialize \$entry]
+		}
+	    }
+	    \$ss destroy
+	    return {::xotcl::Class proc __unknown name {$resolver \$name}}
+	}
+    }]
+
+    #
+    # Register callback to be called on cleanup. This will trash lazily loaded
+    # procs which have changed since.
+    #
+
+    ttrace::addcleanup {
+	variable resolveproc
+	foreach cmd [array names resolveproc] {
+	    set def [ttrace::getentry proc $cmd]
+	    if {$def != ""} {
+		set new [lindex $def 0]
+		set old $resolveproc($cmd)
+		if {[info command $cmd] != "" && $new != $old} {
+		    catch {rename $cmd ""}
+		}
+	    }
+	}
+    }
+}
+
+# EOF
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# tab-width: 8
+# indent-tabs-mode: nil
+# End:

src/vfs/punk8win.vfs/lib_tcl8/twapi-5.0b1/wts.tcl

@@ -1,64 +0,0 @@
-
-# Copyright (c) 2021 Ashok P. Nadkarni
-# All rights reserved.
-#
-# See the file LICENSE for license
-
-namespace eval twapi {
-    variable _wts_session_monitors
-    set _wts_session_monitors [dict create]
-}
-
-proc twapi::start_wts_session_monitor {script args} {
-    variable _wts_session_monitors
-
-    parseargs args {
-        all
-    } -maxleftover 0 -setvars]
-
-    set script [lrange $script 0 end]; # Verify syntactically a list
-
-    set id "wts#[TwapiId]"
-    if {[dict size $_wts_session_monitors] == 0} {
-        # No monitoring in progress. Start it
-        # 0x2B1 -> WM_WTSSESSION_CHANGE
-        Twapi_WTSRegisterSessionNotification $all
-        _register_script_wm_handler 0x2B1 [list [namespace current]::_wts_session_change_handler] 0
-    }
-
-    dict set  _wts_session_monitors $id $script
-    return $id
-}
-
-
-proc twapi::stop_wts_session_monitor {id} {
-    variable _wts_session_monitors
-
-    if {![dict exists $_wts_session_monitors $id]} {
-        return
-    }
-
-    dict unset _wts_session_monitors $id
-    if {[dict size $_wts_session_monitors] == 0} {
-        # 0x2B1 -> WM_WTSSESSION_CHANGE
-        _unregister_script_wm_handler 0x2B1 [list [namespace current]::_wts_session_handler]
-        Twapi_WTSUnRegisterSessionNotification
-    }
-}
-
-proc twapi::_wts_session_change_handler {msg change session_id msgpos ticks} {
-    variable _wts_session_monitors
-
-    if {[dict size $_wts_session_monitors] == 0} {
-        return; # Not an error, could have deleted while already queued
-    }
-
-    dict for {id script} $_wts_session_monitors {
-        set code [catch {uplevel #0 [linsert $script end $change $session_id]} msg]
-        if {$code == 1} {
-            # Error - put in background but we do not abort
-            after 0 [list error $msg $::errorInfo $::errorCode]
-        }
-    }
-    return
-}

src/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/LICENSE

@@ -1,29 +1,29 @@
-Copyright (c) 2003-2024, 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.
+Copyright (c) 2003-2024, 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/README.md

@@ -1,73 +1,77 @@
-# Tcl Windows API (TWAPI) extension
-
-The Tcl Windows API (TWAPI) extension provides access to the Windows API from
-within the Tcl scripting language.
-
-  * Project source repository is at https://github.com/apnadkarni/twapi
-  * Documentation is at https://twapi.magicsplat.com
-  * Binary distribution is at https://sourceforge.net/projects/twapi/files/Current%20Releases/Tcl%20Windows%20API/
-
-## Supported platforms
-
-TWAPI 5.0 requires
-
-  * Windows 7 SP1 or later
-  * Tcl 8.6.10+ or Tcl 9.x
-
-### Binary distribution
-
-The single binary distribution supports Tcl 8.6 and Tcl 9 for both 32- and
-64-bit platforms.
-
-It requires the VC++ runtime to already be installed
-on the system. Download from https://learn.microsoft.com/en-us/cpp/windows/latest-supported-vc-redist if necessary.
-
-Windows 7 and 8.x also require the Windows UCRT runtime to be installed if not
-present. Download from https://support.microsoft.com/en-gb/topic/update-for-universal-c-runtime-in-windows-c0514201-7fe6-95a3-b0a5-287930f3560c.
-
-In most cases, both the above should already be present on the system.
-
-Note that the *modular* and single file *bin* in 4.x distributions are no longer
-available and will not be supported in 5.0.
-
-## TWAPI Summary
-
-The Tcl Windows API (TWAPI) extension provides access to the Windows API from
-within the Tcl scripting language.
-
-Functions in the following areas are implemented:
-
-  * System functions including OS and CPU information,
-    shutdown and message formatting
-  * User and group management
-  * COM client and server support
-  * Security and resource access control
-  * Window management
-  * User input: generate key/mouse input and hotkeys
-  * Basic sound playback functions
-  * Windows services
-  * Windows event log access
-  * Windows event tracing
-  * Process and thread management
-  * Directory change monitoring
-  * Lan Manager and file and print shares
-  * Drive information, file system types etc.
-  * Network configuration and statistics
-  * Network connection monitoring and control
-  * Named pipes
-  * Clipboard access
-  * Taskbar icons and notifications
-  * Console mode functions
-  * Window stations and desktops
-  * Internationalization
-  * Task scheduling
-  * Shell functions
-  * Registry
-  * Windows Management Instrumentation
-  * Windows Installer
-  * Synchronization
-  * Power management
-  * Device I/O and management
-  * Crypto API and certificates
-  * SSL/TLS
-  * Windows Performance Counters
+# Tcl Windows API (TWAPI) extension
+
+The Tcl Windows API (TWAPI) extension provides access to the Windows API
+from within the Tcl scripting language.
+
+  * Project source repository is at https://github.com/apnadkarni/twapi
+  * Binary distribution is at https://sourceforge.net/projects/twapi/files/Current%20Releases/Tcl%20Windows%20API/
+  * Documentation is at https://twapi.magicsplat.com
+  * Change history is at https://twapi.magicsplat.com/v5.1/versionhistory.html
+
+## Supported platforms
+
+TWAPI 5.x requires
+
+  * Windows 7 SP1 or later
+  * Tcl 8.6.10+ or Tcl 9.x
+
+### Binary distribution
+
+The single binary distribution supports Tcl 8.6 and Tcl 9 for both 32-
+and 64-bit platforms.
+
+It requires the VC++ runtime to already be installed on the system.
+Download from
+https://learn.microsoft.com/en-us/cpp/windows/latest-supported-vc-redist
+if necessary.
+
+Windows 7 and 8.x also require the Windows UCRT runtime to be installed
+if not present. Download from
+https://support.microsoft.com/en-gb/topic/update-for-universal-c-runtime-in-windows-c0514201-7fe6-95a3-b0a5-287930f3560c.
+
+In most cases, both the above should already be present on the system.
+
+Note that the *modular* and single file *bin* in 4.x distributions are
+no longer available.
+
+## TWAPI Summary
+
+The Tcl Windows API (TWAPI) extension provides access to the Windows API
+from within the Tcl scripting language.
+
+Functions in the following areas are implemented:
+
+  * System functions including OS and CPU information,
+    shutdown and message formatting
+  * User and group management
+  * COM client and server support
+  * Security and resource access control
+  * Window management
+  * User input: generate key/mouse input and hotkeys
+  * Basic sound playback functions
+  * Windows services
+  * Windows event log access
+  * Windows event tracing
+  * Process and thread management
+  * Directory change monitoring
+  * Lan Manager and file and print shares
+  * Drive information, file system types etc.
+  * Network configuration and statistics
+  * Network connection monitoring and control
+  * Named pipes
+  * Clipboard access
+  * Taskbar icons and notifications
+  * Console mode functions
+  * Window stations and desktops
+  * Internationalization
+  * Task scheduling
+  * Shell functions
+  * Registry
+  * Windows Management Instrumentation
+  * Windows Installer
+  * Synchronization
+  * Power management
+  * Device I/O and management
+  * Crypto API and certificates
+  * SSL/TLS
+  * Windows Performance Counters

src/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/adsi.tcl

@@ -1,28 +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]
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/apputil.tcl

@@ -1,114 +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
-    }
-}
-
-
-
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/clipboard.tcl

@@ -1,254 +1,314 @@
-#
-# 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
-    }
-}
+#
+# 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::_init_global_heap_formats {} {
+    variable _clipboard_global_heap_formats
+    # The following types are known to return global handles to memory
+    # 1 - CF_TEXT
+    # 6 - CF_TIFF
+    # 7 - CF_OEMTEXT
+    # 8 - CF_DIB
+    # 13 - CF_UNICODE
+    # 15 - CF_HDROP
+    # 16 - CF_LOCALE
+    # 17 - CF_DIBV5
+    # Non-Standard formats "HTML Format", "PNG", "GIF"
+    array set _clipboard_global_heap_formats {
+        1 {} 6 {} 7 {} 8 {} 13 {} 15 {} 16 {} 17 {}
+    }
+    foreach fmt [list "HTML Format" PNG GIF] {
+        set fmt [format %u [register_clipboard_format $fmt]]
+        set _clipboard_global_heap_formats($fmt) ""
+    }
+    proc _init_global_heap_formats {} {}
+}
+
+proc twapi::clipboard_format_uses_global_heap {args} {
+    _init_global_heap_formats
+    variable _clipboard_global_heap_formats
+    set fmts [lmap fmt $args {
+        if {[string is integer $fmt]} {
+            if {$fmt < 0 || $fmt > 0x7fffffff} {
+                error "Clipboard format $fmt out of range."
+            }
+        } else {
+            set fmt [register_clipboard_format $fmt]
+        }
+        format %u $fmt
+    }]
+
+    # All formats verified, now add them
+    foreach fmt $fmts {
+        set _clipboard_global_heap_formats($fmt) ""
+    }
+}
+
+proc twapi::_check_if_global_memory_format {fmt} {
+    _init_global_heap_formats
+    variable _clipboard_global_heap_formats
+    set fmt [format %u $fmt]
+    if {[info exists _clipboard_global_heap_formats($fmt)]} {
+        return
+    }
+    error "Unsupported format $fmt."
+}
+
+proc twapi::_read_clipboard {fmt} {
+    # Always catch errors and close clipboard before passing exception on
+    # Also ensure memory unlocked
+    trap {
+        set h [GetClipboardData $fmt]
+        if {$fmt == 14} {
+            # CF_ENHMETAFILE
+            set data [GetEnhMetaFileBits $h]
+        } else {
+            _check_if_global_memory_format $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 {
+        _check_if_global_memory_format $fmt
+
+        # 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/eventlog.tcl

@@ -1,391 +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]
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/handle.tcl

@@ -1,236 +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}]
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/msi.tcl

@@ -1,432 +1,432 @@
-#
-# 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
-    variable 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
-    variable MsiReadStream
-    array set MsiReadStream {msiReadStreamInteger 0 msiReadStreamBytes 1 msiReadStreamAnsi 2 msiReadStreamDirect 3}
-
-    # Enum MsiRunMode
-    variable 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
-    variable MsiDatabaseState
-    array set MsiDatabaseState {msiDatabaseStateRead 0 msiDatabaseStateWrite 1}
-
-    # Enum MsiViewModify
-    variable 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
-    variable MsiColumnInfo
-    array set MsiColumnInfo {msiColumnInfoNames 0 msiColumnInfoTypes 1}
-
-    # Enum MsiTransformError
-    variable MsiTransformError
-    array set MsiTransformError {msiTransformErrorNone 0 msiTransformErrorAddExistingRow 1 msiTransformErrorDeleteNonExistingRow 2 msiTransformErrorAddExistingTable 4 msiTransformErrorDeleteNonExistingTable 8 msiTransformErrorUpdateNonExistingRow 16 msiTransformErrorChangeCodePage 32 msiTransformErrorViewTransform 256}
-
-    # Enum MsiEvaluateCondition
-    variable MsiEvaluateCondition
-    array set MsiEvaluateCondition {msiEvaluateConditionFalse 0 msiEvaluateConditionTrue 1 msiEvaluateConditionNone 2 msiEvaluateConditionError 3}
-
-    # Enum MsiTransformValidation
-    variable 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
-    variable MsiDoActionStatus
-    array set MsiDoActionStatus {msiDoActionStatusNoAction 0 msiDoActionStatusSuccess 1 msiDoActionStatusUserExit 2 msiDoActionStatusFailure 3 msiDoActionStatusSuspend 4 msiDoActionStatusFinished 5 msiDoActionStatusWrongState 6 msiDoActionStatusBadActionData 7}
-
-    # Enum MsiMessageStatus
-    variable MsiMessageStatus
-    array set MsiMessageStatus {msiMessageStatusError -1 msiMessageStatusNone 0 msiMessageStatusOk 1 msiMessageStatusCancel 2 msiMessageStatusAbort 3 msiMessageStatusRetry 4 msiMessageStatusIgnore 5 msiMessageStatusYes 6 msiMessageStatusNo 7}
-
-    # Enum MsiMessageType
-    variable 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
-    variable 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
-    variable MsiCostTree
-    array set MsiCostTree {msiCostTreeSelfOnly 0 msiCostTreeChildren 1 msiCostTreeParents 2}
-
-    # Enum MsiReinstallMode
-    variable 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
-    variable MsiInstallType
-    array set MsiInstallType {msiInstallTypeDefault 0 msiInstallTypeNetworkImage 1 msiInstallTypeSingleInstance 2}
-
-    # Enum MsiInstallMode
-    variable MsiInstallMode
-    array set MsiInstallMode {msiInstallModeNoSourceResolution -3 msiInstallModeNoDetection -2 msiInstallModeExisting -1 msiInstallModeDefault 0}
-
-    # Enum MsiSignatureInfo
-    variable MsiSignatureInfo
-    array set MsiSignatureInfo {msiSignatureInfoCertificate 0 msiSignatureInfoHash 1}
-
-    # Enum MsiInstallContext
-    variable MsiInstallContext
-    array set MsiInstallContext {msiInstallContextFirstVisible 0 msiInstallContextUserManaged 1 msiInstallContextUser 2 msiInstallContextMachine 4 msiInstallContextAllUserManaged 8}
-
-    # Enum MsiInstallSourceType
-    variable MsiInstallSourceType
-    array set MsiInstallSourceType {msiInstallSourceTypeUnknown 0 msiInstallSourceTypeNetwork 1 msiInstallSourceTypeURL 2 msiInstallSourceTypeMedia 4}
-
-    # Enum MsiAssemblyType
-    variable MsiAssemblyType
-    array set MsiAssemblyType {msiProvideAssemblyNet 0 msiProvideAssemblyWin32 1}
-
-    # Enum MsiProductScriptInfo
-    variable MsiProductScriptInfo
-    array set MsiProductScriptInfo {msiProductScriptInfoProductCode 0 msiProductScriptInfoProductLanguage 1 msiProductScriptInfoProductVersion 2 msiProductScriptInfoProductName 3 msiProductScriptInfoPackageName 4}
-
-    # Enum MsiAdvertiseProductContext
-    variable MsiAdvertiseProductContext
-    array set MsiAdvertiseProductContext {msiAdvertiseProductMachine 0 msiAdvertiseProductUser 1}
-
-    # Enum Constants
-    variable Constants
-    array set Constants {msiDatabaseNullInteger -2147483648}
-
-    # Enum MsiOpenDatabaseMode
-    variable MsiOpenDatabaseMode
-    array set MsiOpenDatabaseMode {msiOpenDatabaseModeReadOnly 0 msiOpenDatabaseModeTransact 1 msiOpenDatabaseModeDirect 2 msiOpenDatabaseModeCreate 3 msiOpenDatabaseModeCreateDirect 4 msiOpenDatabaseModePatchFile 32}
-
-    # Enum MsiSignatureOption
-    variable MsiSignatureOption
-    array set MsiSignatureOption {msiSignatureOptionInvalidHashFatal 1}
-
-    # Enum MsiAdvertiseProductPlatform
-    variable MsiAdvertiseProductPlatform
-    array set MsiAdvertiseProductPlatform {msiAdvertiseCurrentPlatform 0 msiAdvertiseX86Platform 1 msiAdvertiseIA64Platform 2 msiAdvertiseX64Platform 4}
-
-    # Enum MsiAdvertiseProductOptions
-    variable MsiAdvertiseProductOptions
-    array set MsiAdvertiseProductOptions {msiAdvertiseDefault 0 msiAdvertiseSingleInstance 1}
-
-    # Enum MsiAdvertiseScriptFlags
-    variable 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}
-
+#
+# 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
+    variable 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
+    variable MsiReadStream
+    array set MsiReadStream {msiReadStreamInteger 0 msiReadStreamBytes 1 msiReadStreamAnsi 2 msiReadStreamDirect 3}
+
+    # Enum MsiRunMode
+    variable 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
+    variable MsiDatabaseState
+    array set MsiDatabaseState {msiDatabaseStateRead 0 msiDatabaseStateWrite 1}
+
+    # Enum MsiViewModify
+    variable 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
+    variable MsiColumnInfo
+    array set MsiColumnInfo {msiColumnInfoNames 0 msiColumnInfoTypes 1}
+
+    # Enum MsiTransformError
+    variable MsiTransformError
+    array set MsiTransformError {msiTransformErrorNone 0 msiTransformErrorAddExistingRow 1 msiTransformErrorDeleteNonExistingRow 2 msiTransformErrorAddExistingTable 4 msiTransformErrorDeleteNonExistingTable 8 msiTransformErrorUpdateNonExistingRow 16 msiTransformErrorChangeCodePage 32 msiTransformErrorViewTransform 256}
+
+    # Enum MsiEvaluateCondition
+    variable MsiEvaluateCondition
+    array set MsiEvaluateCondition {msiEvaluateConditionFalse 0 msiEvaluateConditionTrue 1 msiEvaluateConditionNone 2 msiEvaluateConditionError 3}
+
+    # Enum MsiTransformValidation
+    variable 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
+    variable MsiDoActionStatus
+    array set MsiDoActionStatus {msiDoActionStatusNoAction 0 msiDoActionStatusSuccess 1 msiDoActionStatusUserExit 2 msiDoActionStatusFailure 3 msiDoActionStatusSuspend 4 msiDoActionStatusFinished 5 msiDoActionStatusWrongState 6 msiDoActionStatusBadActionData 7}
+
+    # Enum MsiMessageStatus
+    variable MsiMessageStatus
+    array set MsiMessageStatus {msiMessageStatusError -1 msiMessageStatusNone 0 msiMessageStatusOk 1 msiMessageStatusCancel 2 msiMessageStatusAbort 3 msiMessageStatusRetry 4 msiMessageStatusIgnore 5 msiMessageStatusYes 6 msiMessageStatusNo 7}
+
+    # Enum MsiMessageType
+    variable 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
+    variable 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
+    variable MsiCostTree
+    array set MsiCostTree {msiCostTreeSelfOnly 0 msiCostTreeChildren 1 msiCostTreeParents 2}
+
+    # Enum MsiReinstallMode
+    variable 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
+    variable MsiInstallType
+    array set MsiInstallType {msiInstallTypeDefault 0 msiInstallTypeNetworkImage 1 msiInstallTypeSingleInstance 2}
+
+    # Enum MsiInstallMode
+    variable MsiInstallMode
+    array set MsiInstallMode {msiInstallModeNoSourceResolution -3 msiInstallModeNoDetection -2 msiInstallModeExisting -1 msiInstallModeDefault 0}
+
+    # Enum MsiSignatureInfo
+    variable MsiSignatureInfo
+    array set MsiSignatureInfo {msiSignatureInfoCertificate 0 msiSignatureInfoHash 1}
+
+    # Enum MsiInstallContext
+    variable MsiInstallContext
+    array set MsiInstallContext {msiInstallContextFirstVisible 0 msiInstallContextUserManaged 1 msiInstallContextUser 2 msiInstallContextMachine 4 msiInstallContextAllUserManaged 8}
+
+    # Enum MsiInstallSourceType
+    variable MsiInstallSourceType
+    array set MsiInstallSourceType {msiInstallSourceTypeUnknown 0 msiInstallSourceTypeNetwork 1 msiInstallSourceTypeURL 2 msiInstallSourceTypeMedia 4}
+
+    # Enum MsiAssemblyType
+    variable MsiAssemblyType
+    array set MsiAssemblyType {msiProvideAssemblyNet 0 msiProvideAssemblyWin32 1}
+
+    # Enum MsiProductScriptInfo
+    variable MsiProductScriptInfo
+    array set MsiProductScriptInfo {msiProductScriptInfoProductCode 0 msiProductScriptInfoProductLanguage 1 msiProductScriptInfoProductVersion 2 msiProductScriptInfoProductName 3 msiProductScriptInfoPackageName 4}
+
+    # Enum MsiAdvertiseProductContext
+    variable MsiAdvertiseProductContext
+    array set MsiAdvertiseProductContext {msiAdvertiseProductMachine 0 msiAdvertiseProductUser 1}
+
+    # Enum Constants
+    variable Constants
+    array set Constants {msiDatabaseNullInteger -2147483648}
+
+    # Enum MsiOpenDatabaseMode
+    variable MsiOpenDatabaseMode
+    array set MsiOpenDatabaseMode {msiOpenDatabaseModeReadOnly 0 msiOpenDatabaseModeTransact 1 msiOpenDatabaseModeDirect 2 msiOpenDatabaseModeCreate 3 msiOpenDatabaseModeCreateDirect 4 msiOpenDatabaseModePatchFile 32}
+
+    # Enum MsiSignatureOption
+    variable MsiSignatureOption
+    array set MsiSignatureOption {msiSignatureOptionInvalidHashFatal 1}
+
+    # Enum MsiAdvertiseProductPlatform
+    variable MsiAdvertiseProductPlatform
+    array set MsiAdvertiseProductPlatform {msiAdvertiseCurrentPlatform 0 msiAdvertiseX86Platform 1 msiAdvertiseIA64Platform 2 msiAdvertiseX64Platform 4}
+
+    # Enum MsiAdvertiseProductOptions
+    variable MsiAdvertiseProductOptions
+    array set MsiAdvertiseProductOptions {msiAdvertiseDefault 0 msiAdvertiseSingleInstance 1}
+
+    # Enum MsiAdvertiseScriptFlags
+    variable 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/multimedia.tcl

@@ -1,75 +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
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/namedpipe.tcl

@@ -1,103 +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
-}
-
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/nls.tcl

@@ -1,467 +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"
-    }
-}
-
-
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/pkgIndex.tcl

@@ -1,100 +1,100 @@
-if {$::tcl_platform(platform) ne "windows"} {
-    return
-}
-
-package ifneeded twapi_base 5.0b1 \
-    [list apply [list {dir} {
-        package require platform
-        set packageVer [string map {. {}} 5.0b1]
-        if {[package vsatisfies [package require Tcl] 9]} {
-            set baseDllName "tcl9twapi50b1.dll"
-        } else {
-            set baseDllName "twapi50b1t.dll"
-        }
-        set package "twapi"
-        set package_ns ::$package
-        namespace eval $package_ns {}
-        set package_init_name [string totitle $package]
-
-        # Try to load from current directory and if that fails try from
-        # platform-specific directories. Note on failure to load when the DLL
-        # exists, we do not try to load from other locations as twapi modules
-        # may have been partially set up.
-
-        set dllFound false
-        foreach platform [linsert [::platform::patterns [platform::identify]] 0 .] {
-            if {$platform eq "tcl"} continue
-            set path [file join $dir $platform $baseDllName]
-            if {[file exists $path]} {
-                uplevel #0 [list load $path $package_init_name]
-                set dllFound true
-                break
-            }
-        }
-
-        if {!$dllFound} {
-            error "Could not locate TWAPI dll."
-        }
-
-        # Load was successful
-        set ${package_ns}::dllPath [file normalize $path]
-        set ${package_ns}::packageDir $dir
-        source [file join $dir twapi.tcl]
-        package provide twapi_base 5.0b1
-    }] $dir]
-
-set __twapimods {
-    com
-    msi
-    power
-    printer
-    synch
-    security
-    account
-    apputil
-    clipboard
-    console
-    crypto
-    device
-    etw
-    eventlog
-    mstask
-    multimedia
-    namedpipe
-    network
-    nls
-    os
-    pdh
-    process
-    rds
-    registry
-    resource
-    service
-    share
-    shell
-    storage
-    ui
-    input
-    winsta
-    wmi
-}
-foreach __twapimod $__twapimods {
-    package ifneeded twapi_$__twapimod 5.0b1 \
-        [list apply [list {dir mod} {
-            package require twapi_base 5.0b1
-            source [file join $dir $mod.tcl]
-            package provide twapi_$mod 5.0b1
-        }] $dir $__twapimod]
-}
-
-package ifneeded twapi 5.0b1 \
-    [list apply [list {dir mods} {
-        package require twapi_base 5.0b1
-        foreach mod $mods {
-            package require twapi_$mod 5.0b1
-        }
-        package provide twapi 5.0b1
-    }] $dir $__twapimods]
-
-unset __twapimod
-unset __twapimods
+if {$::tcl_platform(platform) ne "windows"} {
+    return
+}
+
+package ifneeded twapi_base 5.1.1 \
+    [list apply [list {dir} {
+        package require platform
+        set packageVer [string map {. {}} 5.1.1]
+        if {[package vsatisfies [package require Tcl] 9]} {
+            set baseDllName "tcl9twapi511.dll"
+        } else {
+            set baseDllName "twapi511.dll"
+        }
+        set package "twapi"
+        set package_ns ::$package
+        namespace eval $package_ns {}
+        set package_init_name [string totitle $package]
+
+        # Try to load from current directory and if that fails try from
+        # platform-specific directories. Note on failure to load when the DLL
+        # exists, we do not try to load from other locations as twapi modules
+        # may have been partially set up.
+
+        set dllFound false
+        foreach platform [linsert [::platform::patterns [platform::identify]] 0 .] {
+            if {$platform eq "tcl"} continue
+            set path [file join $dir $platform $baseDllName]
+            if {[file exists $path]} {
+                uplevel #0 [list load $path $package_init_name]
+                set dllFound true
+                break
+            }
+        }
+
+        if {!$dllFound} {
+            error "Could not locate TWAPI dll."
+        }
+
+        # Load was successful
+        set ${package_ns}::dllPath [file normalize $path]
+        set ${package_ns}::packageDir $dir
+        source [file join $dir twapi.tcl]
+        package provide twapi_base 5.1.1
+    }] $dir]
+
+set __twapimods {
+    com
+    msi
+    power
+    printer
+    synch
+    security
+    account
+    apputil
+    clipboard
+    console
+    crypto
+    device
+    etw
+    eventlog
+    mstask
+    multimedia
+    namedpipe
+    network
+    nls
+    os
+    pdh
+    process
+    rds
+    registry
+    resource
+    service
+    share
+    shell
+    storage
+    ui
+    input
+    winsta
+    wmi
+}
+foreach __twapimod $__twapimods {
+    package ifneeded twapi_$__twapimod 5.1.1 \
+        [list apply [list {dir mod} {
+            package require twapi_base 5.1.1
+            source [file join $dir $mod.tcl]
+            package provide twapi_$mod 5.1.1
+        }] $dir $__twapimod]
+}
+
+package ifneeded twapi 5.1.1 \
+    [list apply [list {dir mods} {
+        package require twapi_base 5.1.1
+        foreach mod $mods {
+            package require twapi_$mod 5.1.1
+        }
+        package provide twapi 5.1.1
+    }] $dir $__twapimods]
+
+unset __twapimod
+unset __twapimods

src/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/power.tcl

@@ -1,136 +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]
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/printer.tcl

@@ -1,58 +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]
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/rds.tcl

@@ -1,191 +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 }
-    }
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/registry.tcl

@@ -1,490 +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
-}
-
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/resource.tcl

@@ -1,458 +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
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/synch.tcl

@@ -1,94 +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]
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/win.tcl

@@ -1,131 +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
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/winlog.tcl

@@ -1,304 +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
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/winsta.tcl

@@ -1,113 +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]
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/twapi5.1.1/wmi.tcl

@@ -1,223 +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
-}
+#
+# 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/vfs/punk8win.vfs/lib_tcl8/udp1.0.12/pkgIndex.tcl

@@ -0,0 +1,2 @@
+package ifneeded udp 1.0.12 \
+    [list load [file join $dir udp1012.dll]]