vendor updates - twapi tcllib

src/vendorlib_tcl8/twapi-5.0b1/LICENSE

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

@@ -0,0 +1,73 @@
+# 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

src/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/clipboard.tcl

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

src/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/msi.tcl

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

@@ -0,0 +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

src/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/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/vendorlib_tcl8/twapi-5.0b1/wts.tcl

@@ -0,0 +1,64 @@
+
+# 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/vendorlib_tcl8/twapi4.7.2/metoo.tcl

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

src/vendorlib_tcl8/twapi4.7.2/pkgIndex.tcl

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

src/vendorlib_tcl8/twapi4.7.2/twapi_entry.tcl

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

src/vendorlib_tcl9/tcllib2.0/0compatibility/pkgIndex.tcl

@@ -0,0 +1,8 @@
+# Compatibility wrapper for deprecated packages.
+##
+# Stages
+# [D1] Next Release   - Noted deprecated, with redirection wrappers
+# [D2] Release After  - Wrappers become Blockers, throwing error noting redirection
+# [D3] Release Beyond - All removed.
+##
+# Currently in deprecation [[NONE]]

src/vendorlib_tcl9/tcllib2.0/aes/aes.tcl

@@ -0,0 +1,625 @@
+# aes.tcl - 
+#
+# Copyright (c) 2005 Thorsten Schloermann
+# Copyright (c) 2005 Pat Thoyts <patthoyts@users.sourceforge.net>
+# Copyright (c) 2013 Andreas Kupries
+#
+# A Tcl implementation of the Advanced Encryption Standard (US FIPS PUB 197)
+#
+# AES is a block cipher with a block size of 128 bits and a variable
+# key size of 128, 192 or 256 bits.
+# The algorithm works on each block as a 4x4 state array. There are 4 steps
+# in each round:
+#   SubBytes    a non-linear substitution step using a predefined S-box
+#   ShiftRows   cyclic transposition of rows in the state matrix
+#   MixColumns  transformation upon columns in the state matrix
+#   AddRoundKey application of round specific sub-key
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.5 9
+
+namespace eval ::aes {
+    variable uid
+    if {![info exists uid]} { set uid 0 }
+
+    namespace export aes
+
+    # constants
+
+    # S-box
+    variable sbox {
+        0x63 0x7c 0x77 0x7b 0xf2 0x6b 0x6f 0xc5 0x30 0x01 0x67 0x2b 0xfe 0xd7 0xab 0x76
+        0xca 0x82 0xc9 0x7d 0xfa 0x59 0x47 0xf0 0xad 0xd4 0xa2 0xaf 0x9c 0xa4 0x72 0xc0
+        0xb7 0xfd 0x93 0x26 0x36 0x3f 0xf7 0xcc 0x34 0xa5 0xe5 0xf1 0x71 0xd8 0x31 0x15
+        0x04 0xc7 0x23 0xc3 0x18 0x96 0x05 0x9a 0x07 0x12 0x80 0xe2 0xeb 0x27 0xb2 0x75
+        0x09 0x83 0x2c 0x1a 0x1b 0x6e 0x5a 0xa0 0x52 0x3b 0xd6 0xb3 0x29 0xe3 0x2f 0x84
+        0x53 0xd1 0x00 0xed 0x20 0xfc 0xb1 0x5b 0x6a 0xcb 0xbe 0x39 0x4a 0x4c 0x58 0xcf
+        0xd0 0xef 0xaa 0xfb 0x43 0x4d 0x33 0x85 0x45 0xf9 0x02 0x7f 0x50 0x3c 0x9f 0xa8
+        0x51 0xa3 0x40 0x8f 0x92 0x9d 0x38 0xf5 0xbc 0xb6 0xda 0x21 0x10 0xff 0xf3 0xd2
+        0xcd 0x0c 0x13 0xec 0x5f 0x97 0x44 0x17 0xc4 0xa7 0x7e 0x3d 0x64 0x5d 0x19 0x73
+        0x60 0x81 0x4f 0xdc 0x22 0x2a 0x90 0x88 0x46 0xee 0xb8 0x14 0xde 0x5e 0x0b 0xdb
+        0xe0 0x32 0x3a 0x0a 0x49 0x06 0x24 0x5c 0xc2 0xd3 0xac 0x62 0x91 0x95 0xe4 0x79
+        0xe7 0xc8 0x37 0x6d 0x8d 0xd5 0x4e 0xa9 0x6c 0x56 0xf4 0xea 0x65 0x7a 0xae 0x08
+        0xba 0x78 0x25 0x2e 0x1c 0xa6 0xb4 0xc6 0xe8 0xdd 0x74 0x1f 0x4b 0xbd 0x8b 0x8a
+        0x70 0x3e 0xb5 0x66 0x48 0x03 0xf6 0x0e 0x61 0x35 0x57 0xb9 0x86 0xc1 0x1d 0x9e
+        0xe1 0xf8 0x98 0x11 0x69 0xd9 0x8e 0x94 0x9b 0x1e 0x87 0xe9 0xce 0x55 0x28 0xdf
+        0x8c 0xa1 0x89 0x0d 0xbf 0xe6 0x42 0x68 0x41 0x99 0x2d 0x0f 0xb0 0x54 0xbb 0x16
+    }
+    # inverse S-box
+    variable xobs {
+        0x52 0x09 0x6a 0xd5 0x30 0x36 0xa5 0x38 0xbf 0x40 0xa3 0x9e 0x81 0xf3 0xd7 0xfb
+        0x7c 0xe3 0x39 0x82 0x9b 0x2f 0xff 0x87 0x34 0x8e 0x43 0x44 0xc4 0xde 0xe9 0xcb
+        0x54 0x7b 0x94 0x32 0xa6 0xc2 0x23 0x3d 0xee 0x4c 0x95 0x0b 0x42 0xfa 0xc3 0x4e
+        0x08 0x2e 0xa1 0x66 0x28 0xd9 0x24 0xb2 0x76 0x5b 0xa2 0x49 0x6d 0x8b 0xd1 0x25
+        0x72 0xf8 0xf6 0x64 0x86 0x68 0x98 0x16 0xd4 0xa4 0x5c 0xcc 0x5d 0x65 0xb6 0x92
+        0x6c 0x70 0x48 0x50 0xfd 0xed 0xb9 0xda 0x5e 0x15 0x46 0x57 0xa7 0x8d 0x9d 0x84
+        0x90 0xd8 0xab 0x00 0x8c 0xbc 0xd3 0x0a 0xf7 0xe4 0x58 0x05 0xb8 0xb3 0x45 0x06
+        0xd0 0x2c 0x1e 0x8f 0xca 0x3f 0x0f 0x02 0xc1 0xaf 0xbd 0x03 0x01 0x13 0x8a 0x6b
+        0x3a 0x91 0x11 0x41 0x4f 0x67 0xdc 0xea 0x97 0xf2 0xcf 0xce 0xf0 0xb4 0xe6 0x73
+        0x96 0xac 0x74 0x22 0xe7 0xad 0x35 0x85 0xe2 0xf9 0x37 0xe8 0x1c 0x75 0xdf 0x6e
+        0x47 0xf1 0x1a 0x71 0x1d 0x29 0xc5 0x89 0x6f 0xb7 0x62 0x0e 0xaa 0x18 0xbe 0x1b
+        0xfc 0x56 0x3e 0x4b 0xc6 0xd2 0x79 0x20 0x9a 0xdb 0xc0 0xfe 0x78 0xcd 0x5a 0xf4
+        0x1f 0xdd 0xa8 0x33 0x88 0x07 0xc7 0x31 0xb1 0x12 0x10 0x59 0x27 0x80 0xec 0x5f
+        0x60 0x51 0x7f 0xa9 0x19 0xb5 0x4a 0x0d 0x2d 0xe5 0x7a 0x9f 0x93 0xc9 0x9c 0xef
+        0xa0 0xe0 0x3b 0x4d 0xae 0x2a 0xf5 0xb0 0xc8 0xeb 0xbb 0x3c 0x83 0x53 0x99 0x61
+        0x17 0x2b 0x04 0x7e 0xba 0x77 0xd6 0x26 0xe1 0x69 0x14 0x63 0x55 0x21 0x0c 0x7d
+    }
+}
+
+# aes::Init --
+#
+#	Initialise our AES state and calculate the key schedule. An initialization
+#	vector is maintained in the state for modes that require one. The key must
+#	be binary data of the correct size and the IV must be 16 bytes.
+#
+#	Nk: columns of the key-array
+#	Nr: number of rounds (depends on key-length)
+#	Nb: columns of the text-block, is always 4 in AES
+#
+proc ::aes::Init {mode key iv} {
+    switch -exact -- $mode {
+        ecb - cbc { }
+        cfb - ofb {
+            return -code error "$mode mode not implemented"
+        }
+        default {
+            return -code error "invalid mode \"$mode\":\
+                must be one of ecb or cbc."
+        }
+    }
+
+    set size [expr {[string length $key] << 3}]
+    switch -exact -- $size {
+        128 {set Nk 4; set Nr 10; set Nb 4}
+        192 {set Nk 6; set Nr 12; set Nb 4}
+        256 {set Nk 8; set Nr 14; set Nb 4}
+        default {
+            return -code error "invalid key size \"$size\":\
+                must be one of 128, 192 or 256."
+        }
+    }
+
+    variable uid
+    set Key [namespace current]::[incr uid]
+    upvar #0 $Key state
+    if {[binary scan $iv Iu4 state(I)] != 1} {
+        return -code error "invalid initialization vector: must be 16 bytes"
+    }
+    array set state [list M $mode K $key Nk $Nk Nr $Nr Nb $Nb W {}]
+    ExpandKey $Key
+    return $Key
+}
+
+# aes::Reset --
+#
+#	Reset the initialization vector for the specified key. This permits the
+#	key to be reused for encryption or decryption without the expense of
+#	re-calculating the key schedule.
+#
+proc ::aes::Reset {Key iv} {
+    upvar #0 $Key state
+    if {[binary scan $iv Iu4 state(I)] != 1} {
+        return -code error "invalid initialization vector: must be 16 bytes"
+    }
+    return
+}
+    
+# aes::Final --
+#
+#	Clean up the key state
+#
+proc ::aes::Final {Key} {
+    # FRINK: nocheck
+    unset $Key
+}
+
+# -------------------------------------------------------------------------
+
+# 5.1 Cipher:  Encipher a single block of 128 bits.
+proc ::aes::EncryptBlock {Key block} {
+    upvar #0 $Key state
+    if {[binary scan $block Iu4 data] != 1} {
+        return -code error "invalid block size: blocks must be 16 bytes"
+    }
+
+    if {$state(M) eq {cbc}} {
+        # Loop unrolled.
+        lassign $data     d0 d1 d2 d3
+        lassign $state(I) s0 s1 s2 s3
+        set data [list \
+                      [expr {$d0 ^ $s0}] \
+                      [expr {$d1 ^ $s1}] \
+                      [expr {$d2 ^ $s2}] \
+                      [expr {$d3 ^ $s3}] ]
+    }
+
+    set data [AddRoundKey $Key 0 $data]
+    for {set n 1} {$n < $state(Nr)} {incr n} {
+        set data [AddRoundKey $Key $n [MixColumns [ShiftRows [SubBytes $data]]]]
+    }
+    set data [AddRoundKey $Key $n [ShiftRows [SubBytes $data]]]
+
+    # Bug 2993029:
+    # Force all elements of data into the 32bit range.
+    # Loop unrolled
+    set res [Clamp32 $data]
+
+    set state(I) $res
+    binary format Iu4 $res
+}
+
+# 5.3: Inverse Cipher: Decipher a single 128 bit block.
+proc ::aes::DecryptBlock {Key block} {
+    upvar #0 $Key state
+    if {[binary scan $block Iu4 data] != 1} {
+        return -code error "invalid block size: block must be 16 bytes"
+    }
+    set iv $data
+
+    set n $state(Nr)
+    set data [AddRoundKey $Key $state(Nr) $data]
+    for {incr n -1} {$n > 0} {incr n -1} {
+        set data [InvMixColumns [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]]]
+    }
+    set data [AddRoundKey $Key $n [InvSubBytes [InvShiftRows $data]]]
+    
+    if {$state(M) eq {cbc}} {
+        lassign $data     d0 d1 d2 d3
+        lassign $state(I) s0 s1 s2 s3
+        set data [list \
+                      [expr {($d0 ^ $s0) & 0xffffffff}] \
+                      [expr {($d1 ^ $s1) & 0xffffffff}] \
+                      [expr {($d2 ^ $s2) & 0xffffffff}] \
+                      [expr {($d3 ^ $s3) & 0xffffffff}] ]
+    } else {
+        # Bug 2993029:
+        # The integrated clamping we see above only happens for CBC mode.
+        set data [Clamp32 $data]
+    }
+
+    set state(I) $iv
+    binary format Iu4 $data
+}
+
+proc ::aes::Clamp32 {data} {
+    # Force all elements into 32bit range.
+    lassign $data d0 d1 d2 d3
+    list \
+        [expr {$d0 & 0xffffffff}] \
+        [expr {$d1 & 0xffffffff}] \
+        [expr {$d2 & 0xffffffff}] \
+        [expr {$d3 & 0xffffffff}]
+}
+
+# 5.2: KeyExpansion
+proc ::aes::ExpandKey {Key} {
+    upvar #0 $Key state
+    set Rcon [list 0x00000000 0x01000000 0x02000000 0x04000000 0x08000000 \
+                   0x10000000 0x20000000 0x40000000 0x80000000 0x1b000000 \
+                   0x36000000 0x6c000000 0xd8000000 0xab000000 0x4d000000]
+    # Split the key into Nk big-endian words
+    binary scan $state(K) I* W
+    set max [expr {$state(Nb) * ($state(Nr) + 1)}]
+    set i $state(Nk)
+    set h [expr {$i - 1}]
+    set j 0
+    for {} {$i < $max} {incr i; incr h; incr j} {
+        set temp [lindex $W $h]
+        if {($i % $state(Nk)) == 0} {
+            set sub [SubWord [RotWord $temp]]
+            set rc [lindex $Rcon [expr {$i/$state(Nk)}]]
+            set temp [expr {$sub ^ $rc}]
+        } elseif {$state(Nk) > 6 && ($i % $state(Nk)) == 4} { 
+            set temp [SubWord $temp]
+        }
+        lappend W [expr {[lindex $W $j] ^ $temp}]
+    }
+    set state(W) $W
+}
+
+# 5.2: Key Expansion: Apply S-box to each byte in the 32 bit word
+proc ::aes::SubWord {w} {
+    variable sbox
+    set s3 [lindex $sbox [expr {($w >> 24) & 255}]]
+    set s2 [lindex $sbox [expr {($w >> 16) & 255}]]
+    set s1 [lindex $sbox [expr {($w >> 8 ) & 255}]]
+    set s0 [lindex $sbox [expr { $w        & 255}]]
+    return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}]
+}
+
+proc ::aes::InvSubWord {w} {
+    variable xobs
+    set s3 [lindex $xobs [expr {($w >> 24) & 255}]]
+    set s2 [lindex $xobs [expr {($w >> 16) & 255}]]
+    set s1 [lindex $xobs [expr {($w >> 8 ) & 255}]]
+    set s0 [lindex $xobs [expr { $w        & 255}]]
+    return [expr {($s3 << 24) | ($s2 << 16) | ($s1 << 8) | $s0}]
+}
+
+# 5.2: Key Expansion: Rotate a 32bit word by 8 bits
+proc ::aes::RotWord {w} {
+    return [expr {(($w << 8) | (($w >> 24) & 0xff)) & 0xffffffff}]
+}
+
+# 5.1.1: SubBytes() Transformation
+proc ::aes::SubBytes {words} {
+    lassign $words w0 w1 w2 w3
+    list [SubWord $w0] [SubWord $w1] [SubWord $w2] [SubWord $w3]
+}
+
+# 5.3.2: InvSubBytes() Transformation
+proc ::aes::InvSubBytes {words} {
+    lassign $words w0 w1 w2 w3
+    list [InvSubWord $w0] [InvSubWord $w1] [InvSubWord $w2] [InvSubWord $w3]
+}
+
+# 5.1.2: ShiftRows() Transformation
+proc ::aes::ShiftRows {words} {
+    for {set n0 0} {$n0 < 4} {incr n0} {
+        set n1 [expr {($n0 + 1) % 4}]
+        set n2 [expr {($n0 + 2) % 4}]
+        set n3 [expr {($n0 + 3) % 4}]
+        lappend r [expr {(  [lindex $words $n0] & 0xff000000)
+                         | ([lindex $words $n1] & 0x00ff0000)
+                         | ([lindex $words $n2] & 0x0000ff00)
+                         | ([lindex $words $n3] & 0x000000ff)
+                     }]
+    }
+    return $r
+}
+
+
+# 5.3.1: InvShiftRows() Transformation
+proc ::aes::InvShiftRows {words} {
+    for {set n0 0} {$n0 < 4} {incr n0} {
+        set n1 [expr {($n0 + 1) % 4}]
+        set n2 [expr {($n0 + 2) % 4}]
+        set n3 [expr {($n0 + 3) % 4}]
+        lappend r [expr {(  [lindex $words $n0] & 0xff000000)
+                         | ([lindex $words $n3] & 0x00ff0000)
+                         | ([lindex $words $n2] & 0x0000ff00)
+                         | ([lindex $words $n1] & 0x000000ff)
+                     }]
+    }
+    return $r
+}
+
+# 5.1.3: MixColumns() Transformation
+proc ::aes::MixColumns {words} {
+    set r {}
+    foreach w $words {
+        set r0 [expr {(($w >> 24) & 255)}]
+        set r1 [expr {(($w >> 16) & 255)}]
+        set r2 [expr {(($w >> 8 ) & 255)}]
+        set r3 [expr {( $w        & 255)}]
+
+        set s0 [expr {[GFMult2 $r0] ^ [GFMult3 $r1] ^ $r2 ^ $r3}]
+        set s1 [expr {$r0 ^ [GFMult2 $r1] ^ [GFMult3 $r2] ^ $r3}]
+        set s2 [expr {$r0 ^ $r1 ^ [GFMult2 $r2] ^ [GFMult3 $r3]}]
+        set s3 [expr {[GFMult3 $r0] ^ $r1 ^ $r2 ^ [GFMult2 $r3]}]
+
+        lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}]
+    }
+    return $r
+}
+
+# 5.3.3: InvMixColumns() Transformation
+proc ::aes::InvMixColumns {words} {
+    set r {}
+    foreach w $words {
+        set r0 [expr {(($w >> 24) & 255)}]
+        set r1 [expr {(($w >> 16) & 255)}]
+        set r2 [expr {(($w >> 8 ) & 255)}]
+        set r3 [expr {( $w        & 255)}]
+
+        set s0 [expr {[GFMult0e $r0] ^ [GFMult0b $r1] ^ [GFMult0d $r2] ^ [GFMult09 $r3]}]
+        set s1 [expr {[GFMult09 $r0] ^ [GFMult0e $r1] ^ [GFMult0b $r2] ^ [GFMult0d $r3]}]
+        set s2 [expr {[GFMult0d $r0] ^ [GFMult09 $r1] ^ [GFMult0e $r2] ^ [GFMult0b $r3]}]
+        set s3 [expr {[GFMult0b $r0] ^ [GFMult0d $r1] ^ [GFMult09 $r2] ^ [GFMult0e $r3]}]
+
+        lappend r [expr {($s0 << 24) | ($s1 << 16) | ($s2 << 8) | $s3}]
+    }
+    return $r
+}
+
+# 5.1.4: AddRoundKey() Transformation
+proc ::aes::AddRoundKey {Key round words} {
+    upvar #0 $Key state
+    set r {}
+    set n [expr {$round * $state(Nb)}]
+    foreach w $words {
+        lappend r [expr {$w ^ [lindex $state(W) $n]}]
+        incr n
+    }
+    return $r
+}
+    
+# -------------------------------------------------------------------------
+# ::aes::GFMult*
+#
+#	some needed functions for multiplication in a Galois-field
+#
+proc ::aes::GFMult2 {number} {
+    # this is a tabular representation of xtime (multiplication by 2)
+    # it is used instead of calculation to prevent timing attacks
+    set xtime {
+        0x00 0x02 0x04 0x06 0x08 0x0a 0x0c 0x0e 0x10 0x12 0x14 0x16 0x18 0x1a 0x1c 0x1e
+        0x20 0x22 0x24 0x26 0x28 0x2a 0x2c 0x2e 0x30 0x32 0x34 0x36 0x38 0x3a 0x3c 0x3e 
+        0x40 0x42 0x44 0x46 0x48 0x4a 0x4c 0x4e 0x50 0x52 0x54 0x56 0x58 0x5a 0x5c 0x5e
+        0x60 0x62 0x64 0x66 0x68 0x6a 0x6c 0x6e 0x70 0x72 0x74 0x76 0x78 0x7a 0x7c 0x7e 
+        0x80 0x82 0x84 0x86 0x88 0x8a 0x8c 0x8e 0x90 0x92 0x94 0x96 0x98 0x9a 0x9c 0x9e 
+        0xa0 0xa2 0xa4 0xa6 0xa8 0xaa 0xac 0xae 0xb0 0xb2 0xb4 0xb6 0xb8 0xba 0xbc 0xbe 
+        0xc0 0xc2 0xc4 0xc6 0xc8 0xca 0xcc 0xce 0xd0 0xd2 0xd4 0xd6 0xd8 0xda 0xdc 0xde 
+        0xe0 0xe2 0xe4 0xe6 0xe8 0xea 0xec 0xee 0xf0 0xf2 0xf4 0xf6 0xf8 0xfa 0xfc 0xfe 
+        0x1b 0x19 0x1f 0x1d 0x13 0x11 0x17 0x15 0x0b 0x09 0x0f 0x0d 0x03 0x01 0x07 0x05 
+        0x3b 0x39 0x3f 0x3d 0x33 0x31 0x37 0x35 0x2b 0x29 0x2f 0x2d 0x23 0x21 0x27 0x25 
+        0x5b 0x59 0x5f 0x5d 0x53 0x51 0x57 0x55 0x4b 0x49 0x4f 0x4d 0x43 0x41 0x47 0x45 
+        0x7b 0x79 0x7f 0x7d 0x73 0x71 0x77 0x75 0x6b 0x69 0x6f 0x6d 0x63 0x61 0x67 0x65 
+        0x9b 0x99 0x9f 0x9d 0x93 0x91 0x97 0x95 0x8b 0x89 0x8f 0x8d 0x83 0x81 0x87 0x85 
+        0xbb 0xb9 0xbf 0xbd 0xb3 0xb1 0xb7 0xb5 0xab 0xa9 0xaf 0xad 0xa3 0xa1 0xa7 0xa5 
+        0xdb 0xd9 0xdf 0xdd 0xd3 0xd1 0xd7 0xd5 0xcb 0xc9 0xcf 0xcd 0xc3 0xc1 0xc7 0xc5 
+        0xfb 0xf9 0xff 0xfd 0xf3 0xf1 0xf7 0xf5 0xeb 0xe9 0xef 0xed 0xe3 0xe1 0xe7 0xe5
+    }
+    lindex $xtime $number
+}
+
+proc ::aes::GFMult3 {number} {
+    # multliply by 2 (via GFMult2) and add the number again on the result (via XOR)
+    expr {$number ^ [GFMult2 $number]}
+}
+
+proc ::aes::GFMult09 {number} {
+    # 09 is: (02*02*02) + 01
+    expr {[GFMult2 [GFMult2 [GFMult2 $number]]] ^ $number}
+}
+
+proc ::aes::GFMult0b {number} {
+    # 0b is: (02*02*02) + 02 + 01
+    #return [expr [GFMult2 [GFMult2 [GFMult2 $number]]] ^ [GFMult2 $number] ^ $number]
+    #set g0 [GFMult2 $number]
+    expr {[GFMult09 $number] ^ [GFMult2 $number]}
+}
+
+proc ::aes::GFMult0d {number} {
+    # 0d is: (02*02*02) + (02*02) + 01
+    set temp [GFMult2 [GFMult2 $number]]
+    expr {[GFMult2 $temp] ^ ($temp ^ $number)}
+}
+
+proc ::aes::GFMult0e {number} {
+    # 0e is: (02*02*02) + (02*02) + 02
+    set temp [GFMult2 [GFMult2 $number]]
+    expr {[GFMult2 $temp] ^ ($temp ^ [GFMult2 $number])}
+}
+
+# -------------------------------------------------------------------------
+
+# aes::Encrypt --
+#
+#	Encrypt a blocks of plain text and returns blocks of cipher text.
+#	The input data must be a multiple of the block size (16).
+#
+proc ::aes::Encrypt {Key data} {
+    set len [string length $data]
+    if {($len % 16) != 0} {
+        return -code error "invalid block size: AES requires 16 byte blocks"
+    }
+
+    set result {}
+    for {set i 0} {$i < $len} {incr i 1} {
+        set block [string range $data $i [incr i 15]]
+        append result [EncryptBlock $Key $block]
+    }
+    return $result
+}
+
+# aes::Decrypt --
+#
+#	Decrypt blocks of cipher text and returns blocks of plain text.
+#	The input data must be a multiple of the block size (16).
+#
+proc ::aes::Decrypt {Key data} {
+    set len [string length $data]
+    if {($len % 16) != 0} {
+        return -code error "invalid block size: AES requires 16 byte blocks"
+    }
+
+    set result {}
+    for {set i 0} {$i < $len} {incr i 1} {
+        set block [string range $data $i [incr i 15]]
+        append result [DecryptBlock $Key $block]
+    }
+    return $result
+}
+
+# -------------------------------------------------------------------------
+# chan event handler for chunked file reading.
+#
+proc ::aes::Chunk {Key in {out {}} {chunksize 4096}} {
+    upvar #0 $Key state
+
+    #puts ||CHUNK.X||i=$in|o=$out|c=$chunksize|eof=[eof $in]
+    
+    if {[eof $in]} {
+        chan event $in readable {}
+        set state(reading) 0
+    }
+
+    set data [read $in $chunksize]
+
+    #puts ||CHUNK.R||i=$in|o=$out|c=$chunksize|eof=[eof $in]||[string length $data]||$data||
+
+    # Do nothing when data was read at all.
+    if {$data eq {}} return
+
+    if {[eof $in]} {
+        #puts CHUNK.Z
+        set data [Pad $data 16]
+    }
+
+    #puts ||CHUNK.P||i=$in|o=$out|c=$chunksize|eof=[eof $in]||[string length $data]||$data||
+    
+    if {$out eq {}} {
+        append state(output) [$state(cmd) $Key $data]
+    } else {
+        puts -nonewline $out [$state(cmd) $Key $data]
+    }
+}
+
+proc ::aes::SetOneOf {lst item} {
+    set ndx [lsearch -glob $lst "${item}*"]
+    if {$ndx == -1} {
+        set err [join $lst ", "]
+        return -code error "invalid mode \"$item\": must be one of $err"
+    }
+    lindex $lst $ndx
+}
+
+proc ::aes::CheckSize {what size thing} {
+    if {[string length $thing] != $size} {
+        return -code error "invalid value for $what: must be $size bytes long"
+    }
+    return $thing
+}
+
+proc ::aes::Pad {data blocksize {fill \0}} {
+    set len [string length $data]
+    if {$len == 0} {
+        set data [string repeat $fill $blocksize]
+    } elseif {($len % $blocksize) != 0} {
+        set pad [expr {$blocksize - ($len % $blocksize)}]
+        append data [string repeat $fill $pad]
+    }
+    return $data
+}
+
+proc ::aes::Pop {varname {nth 0}} {
+    upvar 1 $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+proc ::aes::aes {args} {
+    array set opts {-dir encrypt -mode cbc -key {} -in {} -out {} -chunksize 4096 -hex 0}
+    set opts(-iv) [string repeat \0 16]
+    set modes {ecb cbc}
+    set dirs {encrypt decrypt}
+    while {([llength $args] > 1) && [string match -* [set option [lindex $args 0]]]} {
+        switch -exact -- $option {
+            -mode      { set opts(-mode) [SetOneOf $modes [Pop args 1]] }
+            -dir       { set opts(-dir) [SetOneOf $dirs [Pop args 1]] }
+            -iv        { set opts(-iv) [CheckSize -iv 16 [Pop args 1]] }
+            -key       { set opts(-key) [Pop args 1] }
+            -in        { set opts(-in) [Pop args 1] }
+            -out       { set opts(-out) [Pop args 1] }
+            -chunksize { set opts(-chunksize) [Pop args 1] }
+            -hex       { set opts(-hex) 1 }
+            --         { Pop args ; break }
+            default {
+                set err [join [lsort [array names opts]] ", "]
+                return -code error "bad option \"$option\":\
+                    must be one of $err"
+            }
+        }
+        Pop args
+    }
+
+    if {$opts(-key) eq {}} {
+        return -code error "no key provided: the -key option is required"
+    }
+
+    set r {}
+    if {$opts(-in) eq {}} {
+
+        if {[llength $args] != 1} {
+            return -code error "wrong \# args:\
+                should be \"aes ?options...? -key keydata plaintext\""
+        }
+
+        set data [Pad [lindex $args 0] 16]
+        set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
+        if {[string equal $opts(-dir) "encrypt"]} {
+            set r [Encrypt $Key $data]
+        } else {
+            set r [Decrypt $Key $data]
+        }
+
+        if {$opts(-out) ne {}} {
+            puts -nonewline $opts(-out) $r
+            set r {}
+        }
+        Final $Key
+
+    } else {
+
+        if {[llength $args] != 0} {
+            return -code error "wrong \# args:\
+                should be \"aes ?options...? -key keydata -in channel\""
+        }
+
+        set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
+
+        set readcmd [list [namespace origin Chunk] \
+                         $Key $opts(-in) $opts(-out) \
+                         $opts(-chunksize)]
+
+        upvar 1 $Key state
+        set state(reading) 1
+        if {[string equal $opts(-dir) "encrypt"]} {
+            set state(cmd) Encrypt
+        } else {
+            set state(cmd) Decrypt
+        }
+        set state(output) ""
+        chan event $opts(-in) readable $readcmd
+        if {[info commands ::tkwait] != {}} {
+            tkwait variable [subst $Key](reading)
+        } else {
+            vwait [subst $Key](reading)
+        }
+        if {$opts(-out) == {}} {
+            set r $state(output)
+        }
+        Final $Key
+    }
+
+    if {$opts(-hex)} {
+        binary scan $r H* r
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+package provide aes 1.2.2
+
+# -------------------------------------------------------------------------
+# Local variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:

src/vendorlib_tcl9/tcllib2.0/aes/pkgIndex.tcl

@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {
+    # PRAGMA: returnok
+    return
+}
+package ifneeded aes 1.2.2 [list source [file join $dir aes.tcl]]

src/vendorlib_tcl9/tcllib2.0/amazon-s3/pkgIndex.tcl

@@ -0,0 +1,9 @@
+# pkgIndex.tcl --
+# Copyright (c) 2006 Darren New
+# This is for the Amazon S3 web service packages.
+
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {return}
+
+package ifneeded xsxp 1.1   [list source [file join $dir xsxp.tcl]]
+package ifneeded S3   1.0.5 [list source [file join $dir S3.tcl]]
+

src/vendorlib_tcl9/tcllib2.0/amazon-s3/xsxp.tcl

@@ -0,0 +1,254 @@
+# xsxp.tcl --
+#
+###Abstract
+# Extremely Simple XML Parser
+#
+# This is pretty lame, but I needed something like this for S3,
+# and at the time, TclDOM would not work with the new 8.5 Tcl
+# due to version number problems.
+#
+# In addition, this is a pure-value implementation. There is no
+# garbage to clean up in the event of a thrown error, for example.
+# This simplifies the code for sufficiently small XML documents,
+# which is what Amazon's S3 guarantees.
+#
+###Copyright
+# Copyright (c) 2006 Darren New.
+# All Rights Reserved.
+# NO WARRANTIES OF ANY TYPE ARE PROVIDED.
+# COPYING OR USE INDEMNIFIES THE AUTHOR IN ALL WAYS.
+# See the license terms in LICENSE.txt
+#
+###Revision String
+# SCCS: %Z% %M% %I% %E% %U%
+
+# xsxp::parse $xml
+# Returns a parsed XML, or PXML. A pxml is a list.
+# The first element is the name of the tag.
+# The second element is a list of name/value pairs of the
+# associated attribues, if any.
+# The third thru final values are recursively PXML values.
+# If the first element (element zero, that is) is "%PCDATA",
+# then the attributes will be emtpy and the third element
+# will be the text of the element.
+
+# xsxp::fetch $pxml $path ?$part?
+# $pxml is a parsed XML, as returned from xsxp::parse.
+# $path is a list of elements. Each element is the name of
+# a child to look up, optionally followed by a hash ("#")
+# and a string of digits. An emtpy list or an initial empty
+# element selects $pxml. If no hash sign is present, the
+# behavior is as if "#0" had been appended to that element.
+# An element of $path scans the children at the indicated
+# level for the n'th instance of a child whose tag matches
+# the part of the element before the hash sign. If an element
+# is simply "#" followed by digits, that indexed child is
+# selected, regardless of the tags in the children. So
+# an element of #3 will always select the fourth child
+# of the node under consideration.
+# $part defaults to %ALL. It can be one of the following:
+# %ALL - returns the entire selected element.
+# %TAGNAME - returns lindex 0 of the selected element.
+# %ATTRIBUTES - returns lindex 1 of the selected element.
+# %CHILDREN - returns lrange 2 through end of the selected element,
+#   resulting in a list of elements being returned.
+# %PCDATA - returns a concatenation of all the bodies of
+#   direct children of this node whose tag is %PCDATA.
+#   Throws an error if no such children are found. That
+#   is, part=%PCDATA means return the textual content found
+#   in that node but not its children nodes.
+# %PCDATA? - like %PCDATA, but returns an empty string if
+#   no PCDATA is found.
+
+# xsxp::fetchall $pxml_list $path ?$part?
+# Iterates over each PXML in $pxml_list, selecting the indicated
+# path from it, building a new list with the selected data, and
+# returning that new list. For example, $pxml_list might be
+# the %CHILDREN of a particular element, and the $path and $part
+# might select from each child a sub-element in which we're interested.
+
+# xsxp::only $pxml $tagname
+# Iterates over the direct children of $pxml and selects  only
+# those with $tagname as their tag. Returns a list of matching
+# elements.
+
+# xsxp::prettyprint $pxml
+# Outputs to stdout a nested-list notation of the parsed XML.
+
+package require xml
+package provide xsxp 1.1
+
+namespace eval xsxp {
+
+    variable Stack
+    variable Cur
+
+    proc Characterdatacommand {characterdata} {
+	variable Cur
+	# puts "characterdatacommand $characterdata"
+	set x [list %PCDATA {} $characterdata]
+	lappend Cur $x
+    }
+
+    proc Elementstartcommand {name attlist args} {
+	# puts "elementstart $name {$attlist} $args"
+	variable Stack
+	variable Cur
+	lappend Stack $Cur
+	set Cur [list $name $attlist]
+    }
+
+    proc Elementendcommand {args} {
+	# puts "elementend $args"
+	variable Stack
+	variable Cur
+	set x [lindex $Stack end]
+	lappend x $Cur
+	set Cur $x
+	set Stack [lrange $Stack 0 end-1]
+    }
+
+    proc parse {xml} {
+	variable Cur
+	variable Stack
+	set Cur {}
+	set Stack {}
+	set parser [::xml::parser \
+	    -characterdatacommand [namespace code Characterdatacommand] \
+	    -elementstartcommand [namespace code Elementstartcommand] \
+	    -elementendcommand [namespace code Elementendcommand] \
+	    -ignorewhitespace 1 -final 1
+        ]
+	$parser parse $xml
+	$parser free
+	# The following line is needed because the close of the last element
+	# appends the outermost element to the item on the top of the stack.
+	# Since there's nothing on the top of the stack at the close of the
+	# last element, we append the current element to an empty list.
+	# In essence, since we don't really have a terminating condition
+	# on the recursion, an empty stack is still treated like an element.
+	set Cur [lindex $Cur 0]
+        set Cur [Normalize $Cur]
+        return $Cur
+    }
+
+    proc Normalize {pxml} {
+	# This iterates over pxml recursively, finding entries that
+	# start with multiple %PCDATA elements, and coalesces their
+	# content, so if an element contains only %PCDATA, it is
+	# guaranteed to have only one child.
+	# Not really necessary, given definition of part=%PCDATA
+	# However, it makes pretty-prints nicer (for AWS at least)
+	# and ends up with smaller lists. I have no idea why they
+	# would put quotes around an MD5 hash in hex, tho.
+	set dupl 1
+	while {$dupl} {
+	    set first [lindex $pxml 2]
+	    set second [lindex $pxml 3]
+	    if {[lindex $first 0] eq "%PCDATA" && [lindex $second 0] eq "%PCDATA"} {
+		set repl [list %PCDATA {} [lindex $first 2][lindex $second 2]]
+		set pxml [lreplace $pxml 2 3 $repl]
+	    } else {
+		set dupl 0
+		for {set i 2} {$i < [llength $pxml]} {incr i} {
+		    set pxml [lreplace $pxml $i $i [Normalize [lindex $pxml $i]]]
+		}
+	    }
+	}
+	return $pxml
+    }
+
+    proc prettyprint {pxml {chan stdout} {indent 0}} {
+	puts -nonewline $chan [string repeat "  " $indent]
+	if {[lindex $pxml 0] eq "%PCDATA"} {
+	    puts $chan "%PCDATA: [lindex $pxml 2]"
+	    return
+	}
+	puts -nonewline $chan "[lindex $pxml 0]"
+	foreach {name val} [lindex $pxml 1] {
+	    puts -nonewline $chan " $name='$val'"
+	}
+	puts $chan ""
+	foreach node [lrange $pxml 2 end] {
+	    prettyprint $node $chan [expr $indent+1]
+	}
+    }
+
+    proc fetch {pxml path {part %ALL}} {
+	set path [string trim $path /]
+	if {-1 != [string first / $path]} {
+	    set path [split $path /]
+	}
+	foreach element $path {
+	    if {$pxml eq ""} {return ""}
+	    foreach {tag count} [split $element #] {
+		if {$tag ne ""} {
+		    if {$count eq ""} {set count 0}
+		    set pxml [lrange $pxml 2 end]
+		    while {0 <= $count && 0 != [llength $pxml]} {
+			if {$tag eq [lindex $pxml 0 0]} {
+			    incr count -1
+			    if {$count < 0} {
+				# We're done. Go on to next element.
+				set pxml [lindex $pxml 0]
+			    } else {
+				# Not done yet. Throw this away.
+				set pxml [lrange $pxml 1 end]
+			    }
+			} else {
+			    # Not what we want.
+			    set pxml [lrange $pxml 1 end]
+			}
+		    }
+		} else { # tag eq ""
+		    if {$count eq ""} {
+			# Just select whole $pxml
+		    } else {
+			set pxml [lindex $pxml [expr {2+$count}]]
+		    }
+		}
+		break
+	    } ; # done the foreach [split] loop
+	} ; # done all the elements.
+	if {$part eq "%ALL"} {return $pxml}
+	if {$part eq "%ATTRIBUTES"} {return [lindex $pxml 1]}
+	if {$part eq "%TAGNAME"} {return [lindex $pxml 0]}
+	if {$part eq "%CHILDREN"} {return [lrange $pxml 2 end]}
+	if {$part eq "%PCDATA" || $part eq "%PCDATA?"} {
+	    set res "" ; set found 0
+	    foreach elem [lrange $pxml 2 end] {
+		if {"%PCDATA" eq [lindex $elem 0]} {
+		    append res [lindex $elem 2]
+		    set found 1
+		}
+	    }
+	    if {$found || $part eq "%PCDATA?"} {
+		return $res
+	    } else {
+		error "xsxp::fetch did not find requested PCDATA"
+	    }
+	}
+	return $pxml ; # Don't know what he's after
+    }
+
+    proc only {pxml tag} {
+	set res {}
+	foreach element [lrange $pxml 2 end] {
+	    if {[lindex $element 0] eq $tag} {
+		lappend res $element
+	    }
+	}
+	return $res
+    }
+
+    proc fetchall {pxml_list path {part %ALL}} {
+	set res [list]
+	foreach pxml $pxml_list {
+	    lappend res [fetch $pxml $path $part]
+	}
+	return $res
+    }
+}
+
+namespace export xsxp parse prettyprint fetch
+

src/vendorlib_tcl9/tcllib2.0/asn/pkgIndex.tcl

@@ -0,0 +1,4 @@
+# Tcl package index file, version 1.1
+
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {return}
+package ifneeded asn 0.8.5 [list source [file join $dir asn.tcl]]

src/vendorlib_tcl9/tcllib2.0/base32/base32.tcl

@@ -0,0 +1,180 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+## Overview
+# Base32 encoding and decoding of small strings.
+#
+# Management code for switching between Tcl and C accelerated
+# implementations.
+
+# @mdgen EXCLUDE: base32_c.tcl
+
+package require Tcl 8.5 9
+
+namespace eval ::base32 {}
+
+# ### ### ### ######### ######### #########
+## Management of base32 std implementations.
+
+# ::base32::LoadAccelerator --
+#
+#	Loads a named implementation, if possible.
+#
+# Arguments:
+#	key	Name of the implementation to load.
+#
+# Results:
+#	A boolean flag. True if the implementation
+#	was successfully loaded; and False otherwise.
+
+proc ::base32::LoadAccelerator {key} {
+    variable accel
+    set isok 0
+    switch -exact -- $key {
+	critcl {
+	    # Critcl implementation of base32 requires Tcl 8.4.
+	    if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
+	    if {[catch {package require tcllibc}]} {return 0}
+	    set isok [llength [info commands ::base32::critcl_encode]]
+	}
+	tcl {
+	    variable selfdir
+	    if {[catch {source [file join $selfdir base32_tcl.tcl]}]} {return 0}
+	    set isok [llength [info commands ::base32::tcl_encode]]
+	}
+        default {
+            return -code error "invalid accelerator $key:\
+                must be one of [join [KnownImplementations] {, }]"
+        }
+    }
+    set accel($key) $isok
+    return $isok
+}
+
+# ::base32::SwitchTo --
+#
+#	Activates a loaded named implementation.
+#
+# Arguments:
+#	key	Name of the implementation to activate.
+#
+# Results:
+#	None.
+
+proc ::base32::SwitchTo {key} {
+    variable accel
+    variable loaded
+
+    if {[string equal $key $loaded]} {
+	# No change, nothing to do.
+	return
+    } elseif {![string equal $key ""]} {
+	# Validate the target implementation of the switch.
+
+	if {![info exists accel($key)]} {
+	    return -code error "Unable to activate unknown implementation \"$key\""
+	} elseif {![info exists accel($key)] || !$accel($key)} {
+	    return -code error "Unable to activate missing implementation \"$key\""
+	}
+    }
+
+    # Deactivate the previous implementation, if there was any.
+
+    if {![string equal $loaded ""]} {
+	foreach c {encode decode} {
+	    rename ::base32::$c ::base32::${loaded}_$c
+	}
+    }
+
+    # Activate the new implementation, if there is any.
+
+    if {![string equal $key ""]} {
+	foreach c {encode decode} {
+	    rename ::base32::${key}_$c ::base32::$c
+	}
+    }
+
+    # Remember the active implementation, for deactivation by future
+    # switches.
+
+    set loaded $key
+    return
+}
+
+# ::base32::Implementations --
+#
+#	Determines which implementations are
+#	present, i.e. loaded.
+#
+# Arguments:
+#	None.
+#
+# Results:
+#	A list of implementation keys.
+
+proc ::base32::Implementations {} {
+    variable accel
+    set res {}
+    foreach n [array names accel] {
+	if {!$accel($n)} continue
+	lappend res $n
+    }
+    return $res
+}
+
+# ::base32::KnownImplementations --
+#
+#	Determines which implementations are known
+#	as possible implementations.
+#
+# Arguments:
+#	None.
+#
+# Results:
+#	A list of implementation keys. In the order
+#	of preference, most prefered first.
+
+proc ::base32::KnownImplementations {} {
+    return {critcl tcl}
+}
+
+proc ::base32::Names {} {
+    return {
+	critcl {tcllibc based}
+	tcl    {pure Tcl}
+    }
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Data structures.
+
+namespace eval ::base32 {
+    variable  selfdir [file dirname [info script]]
+    variable  loaded  {}
+
+    variable  accel
+    array set accel   {tcl 0 critcl 0}
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Choose an implementation,
+## most prefered first. Loads only one of the
+## possible implementations. And activates it.
+
+namespace eval ::base32 {
+    variable e
+    foreach e [KnownImplementations] {
+	if {[LoadAccelerator $e]} {
+	    SwitchTo $e
+	    break
+	}
+    }
+    unset e
+
+    namespace export encode decode
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide base32 0.2

src/vendorlib_tcl9/tcllib2.0/base32/base32_c.tcl

@@ -0,0 +1,254 @@
+# base32c.tcl --
+#
+#       Implementation of a base32 (std) de/encoder for Tcl.
+#
+# Public domain
+#
+# RCS: @(#) $Id: base32_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $
+
+package require critcl
+package require Tcl 8.5 9
+
+namespace eval ::base32 {
+    # Supporting code for the main command.
+    catch {
+	#critcl::cheaders -g
+	#critcl::debug memory symbols
+    }
+
+    # Main commands, encoder & decoder
+
+    critcl::ccommand critcl_encode {dummy interp objc objv} {
+      /* Syntax -*- c -*-
+       * critcl_encode string
+       */
+
+      unsigned char* buf;
+      Tcl_Size       nbuf;
+
+      unsigned char* out;
+      unsigned char* at;
+      int           nout;
+
+      /*
+       * The array used for encoding
+       */                     /* 123456789 123456789 123456789 12 */
+      static const char map[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567";
+
+#define USAGEE "bitstring"
+
+      if (objc != 2) {
+        Tcl_WrongNumArgs (interp, 1, objv, USAGEE); /* OK tcl9 */
+        return TCL_ERROR;
+      }
+
+      buf  = Tcl_GetBytesFromObj (interp, objv[1], &nbuf); /* OK tcl9 */
+      if (buf == NULL) return TCL_ERROR;
+      nout = ((nbuf+4)/5)*8;
+      out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));
+
+      for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) {
+	*(at++) = map [         (buf[0]>>3)                ];
+	*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+	*(at++) = map [ 0x1f &  (buf[1]>>1)                ];
+	*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+	*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
+	*(at++) = map [ 0x1f &  (buf[3]>>2)                ];
+	*(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ];
+	*(at++) = map [ 0x1f &  (buf[4])                   ];
+      }
+      if (nbuf > 0) {
+	/* Process partials at end. */
+	switch (nbuf) {
+	case 1:
+	  /* |01234567|		 2, padding 6
+	   *  xxxxx
+	   *       xxx 00
+	   */
+
+	  *(at++) = map [        (buf[0]>>3) ];
+	  *(at++) = map [ 0x1f & (buf[0]<<2) ];
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  break;
+	case 2: /* x3/=4 */
+	  /* |01234567|01234567|	 4, padding 4
+	   *  xxxxx
+	   *       xxx xx
+	   *             xxxxx
+	   *                  x 0000
+	   */
+
+	  *(at++) = map [         (buf[0]>>3)                ];
+	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
+	  *(at++) = map [ 0x1f &  (buf[1]<<4)                ];
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  break;
+	case 3:
+	  /* |01234567|01234567|01234567|	 5, padding 3
+	   *  xxxxx
+	   *       xxx xx
+	   *             xxxxx
+	   *                  x xxxx
+	   *                        xxxx 0
+	   */
+
+	  *(at++) = map [         (buf[0]>>3)                ];
+	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
+	  *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+	  *(at++) = map [ 0x1f &  (buf[2]<<1)                ];
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  break;
+	case 4:
+	  /* |01234567|01234567|01234567|012334567|	 7, padding 1
+	   *  xxxxx
+	   *       xxx xx
+	   *             xxxxx
+	   *                  x xxxx
+	   *                        xxxx
+	   *                             xxxxx
+	   *                                  xxxx 0
+	   */
+
+	  *(at++) = map [         (buf[0]>>3)                ];
+	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
+	  *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+	  *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
+	  *(at++) = map [ 0x1f &  (buf[3]>>2)                ];
+	  *(at++) = map [ 0x1f &  (buf[3]<<3)                ];
+	  *(at++) = '=';
+	  break;
+	}
+      }
+
+      Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); /* OK tcl9 */
+      Tcl_Free ((char*) out);
+      return TCL_OK;
+    }
+
+
+    critcl::ccommand critcl_decode {dummy interp objc objv} {
+      /* Syntax -*- c -*-
+       * critcl_decode estring
+       */
+
+      unsigned char* buf;
+      Tcl_Size       nbuf;
+
+      unsigned char* out;
+      unsigned char* at;
+      unsigned char  x [8];
+      int           nout;
+
+      int i, j, a, pad, nx;
+
+      /*
+       * An array for translating single base-32 characters into a value.
+       * Disallowed input characters have a value of 64.  Upper and lower
+       * case is the same. Only 128 chars, as everything above char(127)
+       * is 64.
+       */
+      static const char map [] = {
+	/* \00 */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
+	/* DLE */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
+	/* SPC */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
+	/* '0' */ 64, 64, 26, 27, 28, 29, 30, 31,  64, 64, 64, 64, 64, 64, 64, 64, 
+	/* '@' */ 64,  0,  1,  2,  3,  4,  5,  6,   7,  8,  9, 10, 11, 12, 13, 14,
+	/* 'P' */ 15, 16, 17, 18, 19, 20, 21, 22,  23, 24, 25, 64, 64, 64, 64, 64,
+	/* '`' */ 64,  0,  1,  2,  3,  4,  5,  6,   7,  8,  9, 10, 11, 12, 13, 14,
+	/* 'p' */ 15, 16, 17, 18, 19, 20, 21, 22,  23, 24, 25, 64, 64, 64, 64, 64
+      };
+
+#define USAGED "estring"
+
+      if (objc != 2) {
+        Tcl_WrongNumArgs (interp, 1, objv, USAGED); /* OK tcl9 */
+        return TCL_ERROR;
+      }
+
+      buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); /* OK tcl9 */
+
+      if (nbuf % 8) {
+	Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); /* OK tcl9 */
+        return TCL_ERROR;
+      }
+
+      nout = (nbuf/8)*5 *TCL_UTF_MAX;
+      out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));
+
+#define HIGH(x) (((x) & 0x80) != 0)
+#define BADC(x) ((x) == 64)
+#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)]))
+
+      for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){
+	for (j=0; j < 8; j++){
+	  a = buf [j];
+
+	  if (a == '=') {
+	    x[j] = 0;
+	    pad++;
+	    continue;
+	  } else if (pad) {
+	    char     msg [120];
+	    sprintf (msg,
+		     "Invalid character at index %d: \"=\" (padding found in the middle of the input)",
+		     j-1);
+	    Tcl_Free ((char*) out);
+	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */
+	    return TCL_ERROR;
+	  }
+
+	  if (BADCHAR (a,j)) {
+	    char     msg [100];
+	    sprintf (msg,"Invalid character at index %d: \"%c\"",j,a);
+	    Tcl_Free ((char*) out);
+	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */
+	    return TCL_ERROR;
+	  }
+	}
+
+	*(at++) = (x[0]<<3) | (x[1]>>2)            ;
+	*(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4);
+	*(at++) = (x[3]<<4) | (x[4]>>1)            ;
+	*(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3);
+	*(at++) = (x[6]<<5) | x[7]                 ;
+      }
+
+      if (pad) {
+	if (pad == 1) {
+	  at -= 1;
+	} else if (pad == 3) {
+	  at -= 2;
+	} else if (pad == 4) {
+	  at -= 3;
+	} else if (pad == 6) {
+	  at -= 4;
+	} else {
+	  char     msg [100];
+	  sprintf (msg,"Invalid padding of length %d",pad);
+	  Tcl_Free ((char*) out);
+	  Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */
+	  return TCL_ERROR;
+	}
+      }
+
+      Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); /* OK tcl9 */
+      Tcl_Free ((char*) out);
+      return TCL_OK;
+    }
+}
+
+# ### ### ### ######### ######### #########
+## Ready

src/vendorlib_tcl9/tcllib2.0/base32/base32_tcl.tcl

@@ -0,0 +1,73 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+## Overview
+# Base32 encoding and decoding of small strings.
+
+# ### ### ### ######### ######### #########
+## Notes
+
+# A binary string is split into groups of 5 bits (2^5 == 32), and each
+# group is converted into a printable character as is specified in RFC
+# 3548.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require  base32::core
+namespace eval ::base32 {}
+
+# ### ### ### ######### ######### #########
+## API & Implementation
+
+proc ::base32::tcl_encode {bitstring} {
+    variable forward
+
+    binary scan $bitstring B* bits
+    set len [string length $bits]
+    set rem [expr {$len % 5}]
+    if {$rem} {append bits =/$rem}
+    #puts "($bitstring) => <$bits>"
+
+    return [string map $forward $bits]
+}
+
+proc ::base32::tcl_decode {estring} {
+    variable backward
+    variable invalid
+
+    if {![core::valid $estring $invalid msg]} {
+	return -code error $msg
+    }
+    #puts "I<$estring>"
+    #puts "M<[string map $backward $estring]>"
+
+    return [binary format B* [string map $backward [string toupper $estring]]]
+}
+
+# ### ### ### ######### ######### #########
+## Data structures
+
+namespace eval ::base32 {
+    # Initialize the maps
+    variable forward
+    variable backward
+    variable invalid
+
+    core::define {
+	0 A    9 J   18 S   27 3
+	1 B   10 K   19 T   28 4
+	2 C   11 L   20 U   29 5
+	3 D   12 M   21 V   30 6
+	4 E   13 N   22 W   31 7
+	5 F   14 O   23 X
+	6 G   15 P   24 Y
+	7 H   16 Q   25 Z
+	8 I   17 R   26 2
+    } forward backward invalid ; # {}
+    # puts ///$forward///
+    # puts ///$backward///
+}
+
+# ### ### ### ######### ######### #########
+## Ok

src/vendorlib_tcl9/tcllib2.0/base32/base32core.tcl

@@ -0,0 +1,134 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+#= Overview
+
+# Fundamental handling of base32 conversion tables. Expansion of a
+# basic mapping into a full mapping and its inverse mapping.
+
+# ### ### ### ######### ######### #########
+#= Requisites
+
+namespace eval ::base32::core {}
+
+# ### ### ### ######### ######### #########
+#= API & Implementation
+
+proc ::base32::core::define {map fv bv iv} {
+    variable bits
+    upvar 1 $fv forward $bv backward $iv invalid
+
+    # bytes - bits - padding  - tail       | bits - padding  - tail
+    # 0     -  0   - ""       - "xxxxxxxx" | 0    - ""       - ""
+    # 1     -  8   - "======" - "xx======" | 3    - "======" - "x======"
+    # 2     - 16   - "===="   - "xxxx====" | 1    - "===="   - "x===="
+    # 3     - 24   - "==="    - "xxxxx===" | 4    - "==="    - "x==="
+    # 4     - 32   - "="      - "xxxxxxx=" | 2    - "="      - "x="
+
+    array set _ $bits
+
+    set invalid  "\[^="
+    set forward  {}
+    set btmp     {}
+
+    foreach {code char} $map {
+	set b $_($code)
+
+	append invalid [string tolower $char][string toupper $char]
+
+	# 5 bit remainder
+	lappend forward    $b $char
+	lappend btmp [list $char $b]
+
+	# 4 bit remainder
+	if {$code%2} continue
+	set b [string range $b 0 end-1]
+	lappend forward    ${b}=/4    ${char}===
+	lappend btmp [list ${char}=== $b]
+
+	# 3 bit remainder
+	if {$code%4} continue
+	set b [string range $b 0 end-1]
+	lappend forward    ${b}=/3       ${char}======
+	lappend btmp [list ${char}====== $b]
+
+	# 2 bit remainder
+	if {$code%8} continue
+	set b [string range $b 0 end-1]
+	lappend forward    ${b}=/2  ${char}=
+	lappend btmp [list ${char}= $b]
+
+	# 1 bit remainder
+	if {$code%16} continue
+	set b [string range $b 0 end-1]
+	lappend forward    ${b}=/1     ${char}====
+	lappend btmp [list ${char}==== $b]
+    }
+
+    set backward {}
+    foreach item [lsort -index 0 -decreasing $btmp] {
+	foreach {c b} $item break
+	lappend backward $c $b
+    }
+
+    append invalid "\]"
+    return
+}
+
+proc ::base32::core::valid {estring pattern mv} {
+    upvar 1 $mv message
+
+    if {[string length $estring] % 8} {
+	set message "Length is not a multiple of 8"
+	return 0
+    } elseif {[regexp -indices $pattern $estring where]} {
+	foreach {s e} $where break
+	set message "Invalid character at index $s: \"[string index $estring $s]\""
+	return 0
+    } elseif {[regexp {(=+)$} $estring -> pad]} {
+	set padlen [string length $pad]
+	if {
+	    ($padlen != 6) &&
+	    ($padlen != 4) &&
+	    ($padlen != 3) &&
+	    ($padlen != 1)
+	} {
+	    set message "Invalid padding of length $padlen"
+	    return 0
+	}
+    }
+
+    # Remove the brackets and ^= from the pattern, to construct the
+    # class of valid characters which must not follow the padding.
+
+    set badp "=\[[string range $pattern 3 end-1]\]"
+    if {[regexp -indices $badp $estring where]} {
+	foreach {s e} $where break
+	set message "Invalid character at index $s: \"[string index $estring $s]\" (padding found in the middle of the input)"
+	return 0
+    }
+    return 1
+}
+
+# ### ### ### ######### ######### #########
+## Data structures
+
+namespace eval ::base32::core {
+    namespace export define valid
+
+    variable bits {
+	 0 00000	 1 00001	 2 00010	 3 00011
+	 4 00100	 5 00101	 6 00110	 7 00111
+	 8 01000	 9 01001	10 01010	11 01011
+	12 01100	13 01101	14 01110	15 01111
+	16 10000	17 10001	18 10010	19 10011
+	20 10100	21 10101	22 10110	23 10111
+	24 11000	25 11001	26 11010	27 11011
+	28 11100	29 11101	30 11110	31 11111
+    }
+}
+
+# ### ### ### ######### ######### #########
+#= Registration
+
+package provide base32::core 0.2

src/vendorlib_tcl9/tcllib2.0/base32/base32hex.tcl

@@ -0,0 +1,182 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+## Overview
+# Base32 encoding and decoding of small strings.
+#
+# Management code for switching between Tcl and C accelerated
+# implementations.
+#
+# RCS: @(#) $Id: base32hex.tcl,v 1.3 2008/03/22 23:46:42 andreas_kupries Exp $
+
+# @mdgen EXCLUDE: base32hex_c.tcl
+
+package require Tcl 8.5 9
+
+namespace eval ::base32::hex {}
+
+# ### ### ### ######### ######### #########
+## Management of base32 std implementations.
+
+# ::base32::hex::LoadAccelerator --
+#
+#	Loads a named implementation, if possible.
+#
+# Arguments:
+#	key	Name of the implementation to load.
+#
+# Results:
+#	A boolean flag. True if the implementation
+#	was successfully loaded; and False otherwise.
+
+proc ::base32::hex::LoadAccelerator {key} {
+    variable accel
+    set isok 0
+    switch -exact -- $key {
+	critcl {
+	    # Critcl implementation of base32 requires Tcl 8.4.
+	    if {![package vsatisfies [package provide Tcl] 8.4]} {return 0}
+	    if {[catch {package require tcllibc}]} {return 0}
+	    set isok [llength [info commands ::base32::hex::critcl_encode]]
+	}
+	tcl {
+	    variable selfdir
+	    if {[catch {source [file join $selfdir base32hex_tcl.tcl]}]} {return 0}
+	    set isok [llength [info commands ::base32::hex::tcl_encode]]
+	}
+        default {
+            return -code error "invalid accelerator $key:\
+                must be one of [join [KnownImplementations] {, }]"
+        }
+    }
+    set accel($key) $isok
+    return $isok
+}
+
+# ::base32::hex::SwitchTo --
+#
+#	Activates a loaded named implementation.
+#
+# Arguments:
+#	key	Name of the implementation to activate.
+#
+# Results:
+#	None.
+
+proc ::base32::hex::SwitchTo {key} {
+    variable accel
+    variable loaded
+
+    if {[string equal $key $loaded]} {
+	# No change, nothing to do.
+	return
+    } elseif {![string equal $key ""]} {
+	# Validate the target implementation of the switch.
+
+	if {![info exists accel($key)]} {
+	    return -code error "Unable to activate unknown implementation \"$key\""
+	} elseif {![info exists accel($key)] || !$accel($key)} {
+	    return -code error "Unable to activate missing implementation \"$key\""
+	}
+    }
+
+    # Deactivate the previous implementation, if there was any.
+
+    if {![string equal $loaded ""]} {
+	foreach c {encode decode} {
+	    rename ::base32::hex::$c ::base32::hex::${loaded}_$c
+	}
+    }
+
+    # Activate the new implementation, if there is any.
+
+    if {![string equal $key ""]} {
+	foreach c {encode decode} {
+	    rename ::base32::hex::${key}_$c ::base32::hex::$c
+	}
+    }
+
+    # Remember the active implementation, for deactivation by future
+    # switches.
+
+    set loaded $key
+    return
+}
+
+# ::base32::hex::Implementations --
+#
+#	Determines which implementations are
+#	present, i.e. loaded.
+#
+# Arguments:
+#	None.
+#
+# Results:
+#	A list of implementation keys.
+
+proc ::base32::hex::Implementations {} {
+    variable accel
+    set res {}
+    foreach n [array names accel] {
+	if {!$accel($n)} continue
+	lappend res $n
+    }
+    return $res
+}
+
+# ::base32::hex::KnownImplementations --
+#
+#	Determines which implementations are known
+#	as possible implementations.
+#
+# Arguments:
+#	None.
+#
+# Results:
+#	A list of implementation keys. In the order
+#	of preference, most prefered first.
+
+proc ::base32::hex::KnownImplementations {} {
+    return {critcl tcl}
+}
+
+proc ::base32::hex::Names {} {
+    return {
+	critcl {tcllibc based}
+	tcl    {pure Tcl}
+    }
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Data structures.
+
+namespace eval ::base32::hex {
+    variable  selfdir [file dirname [info script]]
+    variable  loaded  {}
+
+    variable  accel
+    array set accel   {tcl 0 critcl 0}
+}
+
+# ### ### ### ######### ######### #########
+## Initialization: Choose an implementation,
+## most prefered first. Loads only one of the
+## possible implementations. And activates it.
+
+namespace eval ::base32::hex {
+    variable e
+    foreach e [KnownImplementations] {
+	if {[LoadAccelerator $e]} {
+	    SwitchTo $e
+	    break
+	}
+    }
+    unset e
+
+    namespace export encode decode
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide base32::hex 0.2

src/vendorlib_tcl9/tcllib2.0/base32/base32hex_c.tcl

@@ -0,0 +1,254 @@
+# base32hexc.tcl --
+#
+#       Implementation of a base32 (extended hex) de/encoder for Tcl.
+#
+# Public domain
+#
+# RCS: @(#) $Id: base32hex_c.tcl,v 1.3 2008/01/28 22:58:18 andreas_kupries Exp $
+
+package require critcl
+package require Tcl 8.5 9
+
+namespace eval ::base32::hex {
+    # Supporting code for the main command.
+    catch {
+	#critcl::cheaders -g
+	#critcl::debug memory symbols
+    }
+
+    # Main commands, encoder & decoder
+
+    critcl::ccommand critcl_encode {dummy interp objc objv} {
+      /* Syntax -*- c -*-
+       * critcl_encode string
+       */
+
+      unsigned char* buf;
+      Tcl_Size      nbuf;
+
+      unsigned char* out;
+      unsigned char* at;
+      int           nout;
+
+      /*
+       * The array used for encoding
+       */                     /* 123456789 123456789 123456789 12 */
+      static const char map[] = "0123456789ABCDEFGHIJKLMNOPQRSTUV";
+
+#define USAGEE "bitstring"
+
+      if (objc != 2) {
+        Tcl_WrongNumArgs (interp, 1, objv, USAGEE); /* OK tcl9 */
+        return TCL_ERROR;
+      }
+
+      buf  = Tcl_GetBytesFromObj (interp, objv[1], &nbuf); /* OK tcl9 */
+      if (buf == NULL) return TCL_ERROR;
+      nout = ((nbuf+4)/5)*8;
+      out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));
+
+      for (at = out; nbuf >= 5; nbuf -= 5, buf += 5) {
+	*(at++) = map [         (buf[0]>>3)                ];
+	*(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+	*(at++) = map [ 0x1f &  (buf[1]>>1)                ];
+	*(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+	*(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
+	*(at++) = map [ 0x1f &  (buf[3]>>2)                ];
+	*(at++) = map [ 0x1f & ((buf[3]<<3) | (buf[4]>>5)) ];
+	*(at++) = map [ 0x1f &  (buf[4])                   ];
+      }
+      if (nbuf > 0) {
+	/* Process partials at end. */
+	switch (nbuf) {
+	case 1:
+	  /* |01234567|		 2, padding 6
+	   *  xxxxx
+	   *       xxx 00
+	   */
+
+	  *(at++) = map [        (buf[0]>>3) ];
+	  *(at++) = map [ 0x1f & (buf[0]<<2) ];
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  break;
+	case 2: /* x3/=4 */
+	  /* |01234567|01234567|	 4, padding 4
+	   *  xxxxx
+	   *       xxx xx
+	   *             xxxxx
+	   *                  x 0000
+	   */
+
+	  *(at++) = map [         (buf[0]>>3)                ];
+	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
+	  *(at++) = map [ 0x1f &  (buf[1]<<4)                ];
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  break;
+	case 3:
+	  /* |01234567|01234567|01234567|	 5, padding 3
+	   *  xxxxx
+	   *       xxx xx
+	   *             xxxxx
+	   *                  x xxxx
+	   *                        xxxx 0
+	   */
+
+	  *(at++) = map [         (buf[0]>>3)                ];
+	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
+	  *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+	  *(at++) = map [ 0x1f &  (buf[2]<<1)                ];
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  *(at++) = '=';
+	  break;
+	case 4:
+	  /* |01234567|01234567|01234567|012334567|	 7, padding 1
+	   *  xxxxx
+	   *       xxx xx
+	   *             xxxxx
+	   *                  x xxxx
+	   *                        xxxx
+	   *                             xxxxx
+	   *                                  xxxx 0
+	   */
+
+	  *(at++) = map [         (buf[0]>>3)                ];
+	  *(at++) = map [ 0x1f & ((buf[0]<<2) | (buf[1]>>6)) ];
+	  *(at++) = map [ 0x1f &  (buf[1]>>1)                ];
+	  *(at++) = map [ 0x1f & ((buf[1]<<4) | (buf[2]>>4)) ];
+	  *(at++) = map [ 0x1f & ((buf[2]<<1) | (buf[3]>>7)) ];
+	  *(at++) = map [ 0x1f &  (buf[3]>>2)                ];
+	  *(at++) = map [ 0x1f &  (buf[3]<<3)                ];
+	  *(at++) = '=';
+	  break;
+	}
+      }
+
+      Tcl_SetObjResult (interp, Tcl_NewStringObj ((char*)out, nout)); /* OK tcl9 */
+      Tcl_Free ((char*) out);
+      return TCL_OK;
+    }
+
+
+    critcl::ccommand critcl_decode {dummy interp objc objv} {
+      /* Syntax -*- c -*-
+       * critcl_decode estring
+       */
+
+      unsigned char* buf;
+      Tcl_Size      nbuf;
+
+      unsigned char* out;
+      unsigned char* at;
+      unsigned char  x [8];
+      int           nout;
+
+      int i, j, a, pad, nx;
+
+      /*
+       * An array for translating single base-32 characters into a value.
+       * Disallowed input characters have a value of 64.  Upper and lower
+       * case is the same. Only 128 chars, as everything above char(127)
+       * is 64.
+       */
+      static const char map [] = {
+	/* \00 */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
+	/* DLE */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
+	/* SPC */ 64, 64, 64, 64, 64, 64, 64, 64,  64, 64, 64, 64, 64, 64, 64, 64, 
+	/* '0' */  0,  1,  2,  3,  4,  5,  6,  7,   8,  9, 64, 64, 64, 64, 64, 64, 
+	/* '@' */ 64, 10, 11, 12, 13, 14, 15, 16,  17, 18, 19, 20, 21, 22, 23, 24,
+	/* 'P' */ 25, 26, 27, 28, 29, 30, 31, 64,  64, 64, 64, 64, 64, 64, 64, 64,
+	/* '`' */ 64, 10, 11, 12, 13, 14, 15, 16,  17, 18, 19, 20, 21, 22, 23, 24,
+	/* 'p' */ 25, 26, 27, 28, 29, 30, 31, 64,  64, 64, 64, 64, 64, 64, 64, 64
+      };
+
+#define USAGED "estring"
+
+      if (objc != 2) {
+        Tcl_WrongNumArgs (interp, 1, objv, USAGED); /* OK tcl9 */
+        return TCL_ERROR;
+      }
+
+      buf = (unsigned char*) Tcl_GetStringFromObj (objv[1], &nbuf); /* OK tcl9 */
+
+      if (nbuf % 8) {
+	Tcl_SetObjResult (interp, Tcl_NewStringObj ("Length is not a multiple of 8", -1)); /* OK tcl9 */
+        return TCL_ERROR;
+      }
+
+      nout = (nbuf/8)*5 *TCL_UTF_MAX;
+      out  = (unsigned char*) Tcl_Alloc (nout*sizeof(char));
+
+#define HIGH(x) (((x) & 0x80) != 0)
+#define BADC(x) ((x) == 64)
+#define BADCHAR(a,j) (HIGH ((a)) || BADC (x [(j)] = map [(a)]))
+
+      for (pad = 0, i=0, at = out; i < nbuf; i += 8, buf += 8){
+	for (j=0; j < 8; j++){
+	  a = buf [j];
+
+	  if (a == '=') {
+	    x[j] = 0;
+	    pad++;
+	    continue;
+	  } else if (pad) {
+	    char     msg [120];
+	    sprintf (msg,
+		     "Invalid character at index %d: \"=\" (padding found in the middle of the input)",
+		     j-1);
+	    Tcl_Free ((char*) out);
+	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */
+	    return TCL_ERROR;
+	  }
+
+	  if (BADCHAR (a,j)) {
+	    char     msg [100];
+	    sprintf (msg,"Invalid character at index %d: \"%c\"",j,a);
+	    Tcl_Free ((char*) out);
+	    Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */
+	    return TCL_ERROR;
+	  }
+	}
+
+	*(at++) = (x[0]<<3) | (x[1]>>2)            ;
+	*(at++) = (x[1]<<6) | (x[2]<<1) | (x[3]>>4);
+	*(at++) = (x[3]<<4) | (x[4]>>1)            ;
+	*(at++) = (x[4]<<7) | (x[5]<<2) | (x[6]>>3);
+	*(at++) = (x[6]<<5) | x[7]                 ;
+      }
+
+      if (pad) {
+	if (pad == 1) {
+	  at -= 1;
+	} else if (pad == 3) {
+	  at -= 2;
+	} else if (pad == 4) {
+	  at -= 3;
+	} else if (pad == 6) {
+	  at -= 4;
+	} else {
+	  char     msg [100];
+	  sprintf (msg,"Invalid padding of length %d",pad);
+	  Tcl_Free ((char*) out);
+	  Tcl_SetObjResult (interp, Tcl_NewStringObj (msg, -1)); /* OK tcl9 */
+	  return TCL_ERROR;
+	}
+      }
+
+      Tcl_SetObjResult (interp, Tcl_NewByteArrayObj (out, at-out)); /* OK tcl9 */
+      Tcl_Free ((char*) out);
+      return TCL_OK;
+    }
+}
+
+# ### ### ### ######### ######### #########
+## Ready

src/vendorlib_tcl9/tcllib2.0/base32/base32hex_tcl.tcl

@@ -0,0 +1,79 @@
+# -*- tcl -*-
+# This code is hereby put into the public domain.
+# ### ### ### ######### ######### #########
+## Overview
+# Base32 encoding and decoding of small strings.
+
+# ### ### ### ######### ######### #########
+## Notes
+
+# A binary string is split into groups of 5 bits (2^5 == 32), and each
+# group is converted into a printable character as is specified in RFC
+# 3548 for the extended hex encoding.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require  base32::core
+namespace eval ::base32::hex {}
+
+# ### ### ### ######### ######### #########
+## API & Implementation
+
+proc ::base32::hex::tcl_encode {bitstring} {
+    variable forward
+
+    binary scan $bitstring B* bits
+    set len [string length $bits]
+    set rem [expr {$len % 5}]
+    if {$rem} {append bits =/$rem}
+    #puts "($bitstring) => <$bits>"
+
+    return [string map $forward $bits]
+}
+
+proc ::base32::hex::tcl_decode {estring} {
+    variable backward
+    variable invalid
+
+    if {![core::valid $estring $invalid msg]} {
+	return -code error $msg
+    }
+    #puts "I<$estring>"
+    #puts "M<[string map $backward $estring]>"
+
+    return [binary format B* [string map $backward [string toupper $estring]]]
+}
+
+# ### ### ### ######### ######### #########
+## Data structures
+
+namespace eval ::base32::hex {
+    namespace eval core {
+	namespace import ::base32::core::define
+	namespace import ::base32::core::valid
+    }
+
+    namespace export encode decode
+    # Initialize the maps
+    variable forward
+    variable backward
+    variable invalid
+
+    core::define {
+	0 0    9 9        18 I   27 R
+	1 1   10 A        19 J   28 S
+	2 2   11 B        20 K   29 T
+	3 3   12 C        21 L   30 U
+	4 4   13 D        22 M   31 V
+	5 5   14 E        23 N
+	6 6   15 F        24 O
+	7 7        16 G   25 P
+	8 8        17 H   26 Q
+    } forward backward invalid ; # {}
+    # puts ///$forward///
+    # puts ///$backward///
+}
+
+# ### ### ### ######### ######### #########
+## Ok

src/vendorlib_tcl9/tcllib2.0/base32/pkgIndex.tcl

@@ -0,0 +1,4 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} return
+package ifneeded base32       0.2 [list source [file join $dir base32.tcl]]
+package ifneeded base32::hex  0.2 [list source [file join $dir base32hex.tcl]]
+package ifneeded base32::core 0.2 [list source [file join $dir base32core.tcl]]

src/vendorlib_tcl9/tcllib2.0/base64/ascii85.tcl

@@ -0,0 +1,270 @@
+# ascii85.tcl --
+#
+# Encode/Decode ascii85 for a string
+#
+# Copyright (c) Emiliano Gavilan
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.5 9
+
+namespace eval ascii85 {
+    namespace export encode encodefile decode
+    # default values for encode options
+    variable options
+    array set options [list -wrapchar \n -maxlen 76]
+}
+
+# ::ascii85::encode --
+#
+#   Ascii85 encode a given string.
+#
+# Arguments:
+#   args    ?-maxlen maxlen? ?-wrapchar wrapchar? string
+#
+#   If maxlen is 0, the output is not wrapped.
+#
+# Results:
+#   A Ascii85 encoded version of $string, wrapped at $maxlen characters
+#   by $wrapchar.
+
+proc ascii85::encode {args} {
+    variable options
+
+    set alen [llength $args]
+    if {$alen != 1 && $alen != 3 && $alen != 5} {
+        return -code error "wrong # args:\
+            should be \"[lindex [info level 0] 0]\
+            ?-maxlen maxlen?\
+            ?-wrapchar wrapchar? string\""
+    }
+
+    set data [lindex $args end]
+    array set opts [array get options]
+    array set opts [lrange $args 0 end-1]
+    foreach key [array names opts] {
+        if {[lsearch -exact [array names options] $key] == -1} {
+            return -code error "unknown option \"$key\":\
+                must be -maxlen or -wrapchar"
+        }
+    }
+    ##nagelfar ignore
+    if {![string is integer -strict $opts(-maxlen)]
+        || $opts(-maxlen) < 0} {
+        return -code error "expected positive integer but got\
+            \"$opts(-maxlen)\""
+    }
+
+    # perform this check early
+    if {[string length $data] == 0} {
+        return ""
+    }
+
+    # shorten the names, and normalize numeric values.
+    set ml [format %d $opts(-maxlen)]
+    set wc $opts(-wrapchar)
+
+    # if maxlen is zero, don't wrap the output
+    if {$ml == 0} {
+        set wc ""
+    }
+
+    set encoded {}
+
+    binary scan $data c* X
+    set len      [llength $X]
+    set rest     [expr {$len % 4}]
+    set lastidx  [expr {$len - $rest - 1}]
+
+    foreach {b1 b2 b3 b4} [lrange $X 0 $lastidx] {
+        # calculate the 32 bit value
+        # this is an inlined version of the [encode4bytes] proc
+        # included here for performance reasons
+        set val [expr {
+            (  (($b1 & 0xff) << 24)
+              |(($b2 & 0xff) << 16)
+              |(($b3 & 0xff) << 8)
+              | ($b4 & 0xff)
+            ) & 0xffffffff }]
+
+        if {$val == 0} {
+            # four \0 bytes encodes as "z" instead of "!!!!!"
+            append current "z"
+        } else {
+            # no magic numbers here.
+            # 52200625 -> 85 ** 4
+            # 614125   -> 85 ** 3
+            # 7225     -> 85 ** 2
+            append current [binary format ccccc \
+                [expr { ( $val / 52200625) + 33 }] \
+                [expr { (($val % 52200625) / 614125) + 33 }] \
+                [expr { (($val % 614125) / 7225) + 33 }] \
+                [expr { (($val % 7225) / 85) + 33 }] \
+                [expr { ( $val % 85) + 33 }]]
+        }
+
+        if {[string length $current] >= $ml} {
+            append encoded [string range $current 0 [expr {$ml - 1}]] $wc
+            set current    [string range $current $ml end]
+        }
+    }
+
+    if { $rest } {
+        # there are remaining bytes.
+        # pad with \0 and encode not using the "z" convention.
+        # finally, add ($rest + 1) chars.
+        set val 0
+        foreach {b1 b2 b3 b4} [pad [lrange $X [incr lastidx] end] 4 0] break
+        append current [string range [encode4bytes $b1 $b2 $b3 $b4] 0 $rest]
+    }
+    append encoded [regsub -all -- ".{$ml}" $current "&$wc"]
+
+    return $encoded
+}
+
+proc ascii85::encode4bytes {b1 b2 b3 b4} {
+    set val [expr {
+        (  (($b1 & 0xff) << 24)
+          |(($b2 & 0xff) << 16)
+          |(($b3 & 0xff) << 8)
+          | ($b4 & 0xff)
+        ) & 0xffffffff }]
+    return [binary format ccccc \
+            [expr { ( $val / 52200625) + 33 }] \
+            [expr { (($val % 52200625) / 614125) + 33 }] \
+            [expr { (($val % 614125) / 7225) + 33 }] \
+            [expr { (($val % 7225) / 85) + 33 }] \
+            [expr { ( $val % 85) + 33 }]]
+}
+
+# ::ascii85::encodefile --
+#
+#   Ascii85 encode the contents of a file using default values
+#   for maxlen and wrapchar parameters.
+#
+# Arguments:
+#   fname    The name of the file to encode.
+#
+# Results:
+#   An Ascii85 encoded version of the contents of the file.
+#   This is a convenience command
+
+proc ascii85::encodefile {fname} {
+    set fd [open $fname rb]
+    return [encode [read $fd]][close $fd]
+}
+
+# ::ascii85::decode --
+#
+#   Ascii85 decode a given string.
+#
+# Arguments:
+#   string      The string to decode.
+# Leading spaces and tabs are removed, along with trailing newlines
+#
+# Results:
+#   The decoded value.
+
+proc ascii85::decode {data} {
+    # get rid of leading spaces/tabs and trailing newlines
+    set data [string map [list \n {} \t {} { } {}] $data]
+    set len [string length $data]
+
+    # perform this ckeck early
+    if {! $len} {
+        return ""
+    }
+
+    set decoded {}
+    set count 0
+    set group [list]
+    binary scan $data c* X
+
+    foreach char $X {
+        # we must check that every char is in the allowed range
+        if {$char < 33 || $char > 117 } {
+            # "z" is an exception
+            if {$char == 122} {
+                if {$count == 0} {
+                    # if a "z" char appears at the beggining of a group,
+                    # it decodes as four null bytes
+                    append decoded \x00\x00\x00\x00
+                    continue
+                } else {
+                    # if not, is an error
+                    return -code error \
+                        "error decoding data: \"z\" char misplaced"
+                }
+            }
+            # char is not in range and not a "z" at the beggining of a group
+            return -code error \
+                "error decoding data: chars outside the allowed range"
+        }
+
+        lappend group $char
+        incr count
+        if {$count == 5} {
+            # this is an inlined version of the [decode5chars] proc
+            # included here for performance reasons
+            set val [expr {
+                ([lindex $group 0] - 33) * wide(52200625) +
+                ([lindex $group 1] - 33) * 614125 +
+                ([lindex $group 2] - 33) * 7225 +
+                ([lindex $group 3] - 33) * 85 +
+                ([lindex $group 4] - 33) }]
+            if {$val > 0xffffffff} {
+                return -code error "error decoding data: decoded group overflow"
+            } else {
+                append decoded [binary format I $val]
+                incr count -5
+                set group [list]
+            }
+        }
+    }
+
+    set len [llength $group]
+    switch -- $len {
+        0 {
+            # all input has been consumed
+            # do nothing
+        }
+        1 {
+            # a single char is a condition error, there should be at least 2
+            return -code error \
+                "error decoding data: trailing char"
+        }
+        default {
+            # pad with "u"s, decode and add ($len - 1) bytes
+            append decoded [string range \
+                    [decode5chars [pad $group 5 122]] \
+                    0 \
+                    [expr {$len - 2}]]
+        }
+    }
+
+    return $decoded
+}
+
+proc ascii85::decode5chars {group} {
+    set val [expr {
+        ([lindex $group 0] - 33) * wide(52200625) +
+        ([lindex $group 1] - 33) * 614125 +
+        ([lindex $group 2] - 33) * 7225 +
+        ([lindex $group 3] - 33) * 85 +
+        ([lindex $group 4] - 33) }]
+    if {$val > 0xffffffff} {
+        return -code error "error decoding data: decoded group overflow"
+    }
+
+    return [binary format I $val]
+}
+
+proc ascii85::pad {chars len padchar} {
+    while {[llength $chars] < $len} {
+        lappend chars $padchar
+    }
+
+    return $chars
+}
+
+package provide ascii85 1.1.1

src/vendorlib_tcl9/tcllib2.0/base64/base64.tcl

@@ -0,0 +1,411 @@
+# base64.tcl --
+#
+# Encode/Decode base64 for a string
+# Stephen Uhler / Brent Welch (c) 1997 Sun Microsystems
+# The decoder was done for exmh by Chris Garrigues
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# Version 1.0   implemented Base64_Encode, Base64_Decode
+# Version 2.0   uses the base64 namespace
+# Version 2.1   fixes various decode bugs and adds options to encode
+# Version 2.2   is much faster, Tcl8.0 compatible
+# Version 2.2.1 bugfixes
+# Version 2.2.2 bugfixes
+# Version 2.3   bugfixes and extended to support Trf
+# Version 2.4.x bugfixes
+
+# @mdgen EXCLUDE: base64c.tcl
+
+package require Tcl 8.5 9
+namespace eval ::base64 {
+    namespace export encode decode
+}
+
+package provide base64 2.6.1
+
+if {[package vsatisfies [package require Tcl] 8.6 9]} {
+    proc ::base64::encode {args} {
+	binary encode base64 -maxlen 76 {*}$args
+    }
+
+    proc ::base64::decode {string} {
+	# Tcllib is strict with respect to end of input, yet lax for
+	# invalid characters outside of that.
+	regsub -all -- {[^ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/]} $string {} string
+	binary decode base64 -strict $string
+    }
+
+    return
+}
+
+if {![catch {package require Trf 2.0}]} {
+    # Trf is available, so implement the functionality provided here
+    # in terms of calls to Trf for speed.
+
+    # ::base64::encode --
+    #
+    #	Base64 encode a given string.
+    #
+    # Arguments:
+    #	args	?-maxlen maxlen? ?-wrapchar wrapchar? string
+    #
+    #		If maxlen is 0, the output is not wrapped.
+    #
+    # Results:
+    #	A Base64 encoded version of $string, wrapped at $maxlen characters
+    #	by $wrapchar.
+
+    proc ::base64::encode {args} {
+	# Set the default wrapchar and maximum line length to match
+	# the settings for MIME encoding (RFC 3548, RFC 2045). These
+	# are the settings used by Trf as well. Various RFCs allow for
+	# different wrapping characters and wraplengths, so these may
+	# be overridden by command line options.
+	set wrapchar "\n"
+	set maxlen 76
+
+	if { [llength $args] == 0 } {
+	    error "wrong # args: should be \"[lindex [info level 0] 0]\
+		    ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+	}
+
+	set optionStrings [list "-maxlen" "-wrapchar"]
+	for {set i 0} {$i < [llength $args] - 1} {incr i} {
+	    set arg [lindex $args $i]
+	    set index [lsearch -glob $optionStrings "${arg}*"]
+	    if { $index == -1 } {
+		error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+	    }
+	    incr i
+	    if { $i >= [llength $args] - 1 } {
+		error "value for \"$arg\" missing"
+	    }
+	    set val [lindex $args $i]
+
+	    # The name of the variable to assign the value to is extracted
+	    # from the list of known options, all of which have an
+	    # associated variable of the same name as the option without
+	    # a leading "-". The [string range] command is used to strip
+	    # of the leading "-" from the name of the option.
+	    #
+	    # FRINK: nocheck
+	    set [string range [lindex $optionStrings $index] 1 end] $val
+	}
+
+	# [string is] requires Tcl8.2; this works with 8.0 too
+	if {[catch {expr {$maxlen % 2}}]} {
+	    return -code error "expected integer but got \"$maxlen\""
+	} elseif {$maxlen < 0} {
+	    return -code error "expected positive integer but got \"$maxlen\""
+	}
+
+	set string [lindex $args end]
+	set result [::base64 -mode encode -- $string]
+
+	# Trf's encoder implicitly uses the settings -maxlen 76,
+	# -wrapchar \n for its output. We may have to reflow this for
+	# the settings chosen by the user. A second difference is that
+	# Trf closes the output with the wrap char sequence,
+	# always. The code here doesn't. Therefore 'trimright' is
+	# needed in the fast cases.
+
+	if {($maxlen == 76) && [string equal $wrapchar \n]} {
+	    # Both maxlen and wrapchar are identical to Trf's
+	    # settings. This is the super-fast case, because nearly
+	    # nothing has to be done. Only thing to do is strip a
+	    # terminating wrapchar.
+	    set result [string trimright $result]
+	} elseif {$maxlen == 76} {
+	    # wrapchar has to be different here, length is the
+	    # same. We can use 'string map' to transform the wrap
+	    # information.
+	    set result [string map [list \n $wrapchar] \
+			    [string trimright $result]]
+	} elseif {$maxlen == 0} {
+	    # Have to reflow the output to no wrapping. Another fast
+	    # case using only 'string map'. 'trimright' is not needed
+	    # here.
+
+	    set result [string map [list \n ""] $result]
+	} else {
+	    # Have to reflow the output from 76 to the chosen maxlen,
+	    # and possibly change the wrap sequence as well.
+
+	    # Note: After getting rid of the old wrap sequence we
+	    # extract the relevant segments from the string without
+	    # modifying the string. Modification, i.e. removal of the
+	    # processed part, means 'shifting down characters in
+	    # memory', making the algorithm O(n^2). By avoiding the
+	    # modification we stay in O(n).
+
+	    set result [string map [list \n ""] $result]
+	    set l [expr {[string length $result]-$maxlen}]
+	    for {set off 0} {$off < $l} {incr off $maxlen} {
+		append res [string range $result $off [expr {$off+$maxlen-1}]] $wrapchar
+	    }
+	    append res [string range $result $off end]
+	    set result $res
+	}
+
+	return $result
+    }
+
+    # ::base64::decode --
+    #
+    #	Base64 decode a given string.
+    #
+    # Arguments:
+    #	string	The string to decode.  Characters not in the base64
+    #		alphabet are ignored (e.g., newlines)
+    #
+    # Results:
+    #	The decoded value.
+
+    proc ::base64::decode {string} {
+	regsub -all {\s} $string {} string
+	::base64 -mode decode -- $string
+    }
+
+} else {
+    # Without Trf use a pure tcl implementation
+
+    namespace eval base64 {
+	variable base64 {}
+	variable base64_en {}
+
+	# We create the auxiliary array base64_tmp, it will be unset later.
+	variable base64_tmp
+	variable i
+
+	variable i 0
+	variable char
+	foreach char {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z \
+		a b c d e f g h i j k l m n o p q r s t u v w x y z \
+		0 1 2 3 4 5 6 7 8 9 + /} {
+	    set base64_tmp($char) $i
+	    lappend base64_en $char
+	    incr i
+	}
+
+	#
+	# Create base64 as list: to code for instance C<->3, specify
+	# that [lindex $base64 67] be 3 (C is 67 in ascii); non-coded
+	# ascii chars get a {}. we later use the fact that lindex on a
+	# non-existing index returns {}, and that [expr {} < 0] is true
+	#
+
+	# the last ascii char is 'z'
+	variable char
+	variable len
+	variable val
+
+	scan z %c len
+	for {set i 0} {$i <= $len} {incr i} {
+	    set char [format %c $i]
+	    set val {}
+	    if {[info exists base64_tmp($char)]} {
+		set val $base64_tmp($char)
+	    } else {
+		set val {}
+	    }
+	    lappend base64 $val
+	}
+
+	# code the character "=" as -1; used to signal end of message
+	scan = %c i
+	set base64 [lreplace $base64 $i $i -1]
+
+	# remove unneeded variables
+	unset base64_tmp i char len val
+
+	namespace export encode decode
+    }
+
+    # ::base64::encode --
+    #
+    #	Base64 encode a given string.
+    #
+    # Arguments:
+    #	args	?-maxlen maxlen? ?-wrapchar wrapchar? string
+    #
+    #		If maxlen is 0, the output is not wrapped.
+    #
+    # Results:
+    #	A Base64 encoded version of $string, wrapped at $maxlen characters
+    #	by $wrapchar.
+
+    proc ::base64::encode {args} {
+	set base64_en $::base64::base64_en
+
+	# Set the default wrapchar and maximum line length to match
+	# the settings for MIME encoding (RFC 3548, RFC 2045). These
+	# are the settings used by Trf as well. Various RFCs allow for
+	# different wrapping characters and wraplengths, so these may
+	# be overridden by command line options.
+	set wrapchar "\n"
+	set maxlen 76
+
+	if { [llength $args] == 0 } {
+	    error "wrong # args: should be \"[lindex [info level 0] 0]\
+		    ?-maxlen maxlen? ?-wrapchar wrapchar? string\""
+	}
+
+	set optionStrings [list "-maxlen" "-wrapchar"]
+	for {set i 0} {$i < [llength $args] - 1} {incr i} {
+	    set arg [lindex $args $i]
+	    set index [lsearch -glob $optionStrings "${arg}*"]
+	    if { $index == -1 } {
+		error "unknown option \"$arg\": must be -maxlen or -wrapchar"
+	    }
+	    incr i
+	    if { $i >= [llength $args] - 1 } {
+		error "value for \"$arg\" missing"
+	    }
+	    set val [lindex $args $i]
+
+	    # The name of the variable to assign the value to is extracted
+	    # from the list of known options, all of which have an
+	    # associated variable of the same name as the option without
+	    # a leading "-". The [string range] command is used to strip
+	    # of the leading "-" from the name of the option.
+	    #
+	    # FRINK: nocheck
+	    set [string range [lindex $optionStrings $index] 1 end] $val
+	}
+
+	# [string is] requires Tcl8.2; this works with 8.0 too
+	if {[catch {expr {$maxlen % 2}}]} {
+	    return -code error "expected integer but got \"$maxlen\""
+	} elseif {$maxlen < 0} {
+	    return -code error "expected positive integer but got \"$maxlen\""
+	}
+
+	set string [lindex $args end]
+
+	set result {}
+	set state 0
+	set length 0
+
+
+	# Process the input bytes 3-by-3
+
+	binary scan $string c* X
+
+	foreach {x y z} $X {
+	    ADD [lindex $base64_en [expr {($x >>2) & 0x3F}]]
+	    if {$y != {}} {
+		ADD [lindex $base64_en [expr {(($x << 4) & 0x30) | (($y >> 4) & 0xF)}]]
+		if {$z != {}} {
+		    ADD [lindex $base64_en [expr {(($y << 2) & 0x3C) | (($z >> 6) & 0x3)}]]
+		    ADD [lindex $base64_en [expr {($z & 0x3F)}]]
+		} else {
+		    set state 2
+		    break
+		}
+	    } else {
+		set state 1
+		break
+	    }
+	}
+	if {$state == 1} {
+	    ADD [lindex $base64_en [expr {(($x << 4) & 0x30)}]]
+	    ADD =
+	    ADD =
+	} elseif {$state == 2} {
+	    ADD [lindex $base64_en [expr {(($y << 2) & 0x3C)}]]
+	    ADD =
+	}
+	return $result
+    }
+
+    proc ::base64::ADD {x} {
+	# The line length check is always done before appending so
+	# that we don't get an extra newline if the output is a
+	# multiple of $maxlen chars long.
+
+	upvar 1 maxlen maxlen length length result result wrapchar wrapchar
+	if {$maxlen && $length >= $maxlen} {
+	    append result $wrapchar
+	    set length 0
+	}
+	append result $x
+	incr length
+	return
+    }
+
+    # ::base64::decode --
+    #
+    #	Base64 decode a given string.
+    #
+    # Arguments:
+    #	string	The string to decode.  Characters not in the base64
+    #		alphabet are ignored (e.g., newlines)
+    #
+    # Results:
+    #	The decoded value.
+
+    proc ::base64::decode {string} {
+	if {[string length $string] == 0} {return ""}
+
+	set base64 $::base64::base64
+	set output "" ; # Fix for [Bug 821126]
+	set nums {}
+
+	binary scan $string c* X
+	lappend X 61 ;# force a terminator
+	foreach x $X {
+	    set bits [lindex $base64 $x]
+	    if {$bits >= 0} {
+		if {[llength [lappend nums $bits]] == 4} {
+		    foreach {v w z y} $nums break
+		    set a [expr {($v << 2) | ($w >> 4)}]
+		    set b [expr {(($w & 0xF) << 4) | ($z >> 2)}]
+		    set c [expr {(($z & 0x3) << 6) | $y}]
+		    append output [binary format ccc $a $b $c]
+		    set nums {}
+		}
+	    } elseif {$bits == -1} {
+		# = indicates end of data.  Output whatever chars are
+		# left, if any.
+		if {![llength $nums]} break
+		# The encoding algorithm dictates that we can only
+		# have 1 or 2 padding characters.  If x=={}, we must
+		# (*) have 12 bits of input (enough for 1 8-bit
+		# output).  If x!={}, we have 18 bits of input (enough
+		# for 2 8-bit outputs).
+		#
+		# (*) If we don't then the input is broken (bug 2976290).
+
+		foreach {v w z} $nums break
+
+		# Bug 2976290
+		if {$w == {}} {
+		    return -code error "Not enough data to process padding"
+		}
+
+		set a [expr {($v << 2) | (($w & 0x30) >> 4)}]
+		if {$z == {}} {
+		    append output [binary format c $a ]
+		} else {
+		    set b [expr {(($w & 0xF) << 4) | (($z & 0x3C) >> 2)}]
+		    append output [binary format cc $a $b]
+		}
+		break
+	    } else {
+		# RFC 2045 says that line breaks and other characters not part
+		# of the Base64 alphabet must be ignored, and that the decoder
+		# can optionally emit a warning or reject the message.  We opt
+		# not to do so, but to just ignore the character.
+		continue
+	    }
+	}
+	return $output
+    }
+}
+
+# # ## ### ##### ######## ############# #####################
+return
+

src/vendorlib_tcl9/tcllib2.0/base64/base64c.tcl

@@ -0,0 +1,19 @@
+# base64c - Copyright (C) 2003 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# This package is a place-holder for the critcl enhanced code present in
+# the tcllib base64 module.
+#
+# Normally this code will become part of the tcllibc library.
+#
+
+# @sak notprovided base64c
+package require critcl
+package provide base64c 0.1.1
+
+namespace eval ::base64c {
+    variable base64c_rcsid {$Id: base64c.tcl,v 1.5 2008/03/25 07:15:35 andreas_kupries Exp $}
+
+    critcl::ccode {
+        /* no code required in this file */
+    }
+}

src/vendorlib_tcl9/tcllib2.0/base64/pkgIndex.tcl

@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {return}
+package ifneeded base64   2.6.1 [list source [file join $dir base64.tcl]]
+package ifneeded uuencode 1.1.6 [list source [file join $dir uuencode.tcl]]
+package ifneeded yencode  1.1.4 [list source [file join $dir yencode.tcl]]
+package ifneeded ascii85  1.1.1 [list source [file join $dir ascii85.tcl]]

src/vendorlib_tcl9/tcllib2.0/base64/uuencode.tcl

@@ -0,0 +1,337 @@
+# uuencode - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Provide a Tcl only implementation of uuencode and uudecode.
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+package require Tcl 8.5 9;                # tcl minimum version
+
+# Try and get some compiled helper package.
+if {[catch {package require tcllibc}]} {
+    catch {package require Trf}
+}
+
+namespace eval ::uuencode {
+    namespace export encode decode uuencode uudecode
+}
+
+proc ::uuencode::Enc {c} {
+    return [format %c [expr {($c != 0) ? (($c & 0x3f) + 0x20) : 0x60}]]
+}
+
+proc ::uuencode::Encode {s} {
+    set r {}
+    binary scan $s c* d
+    foreach {c1 c2 c3} $d {
+        if {$c1 == {}} {set c1 0}
+        if {$c2 == {}} {set c2 0}
+        if {$c3 == {}} {set c3 0}
+        append r [Enc [expr {$c1 >> 2}]]
+        append r [Enc [expr {(($c1 << 4) & 0o060) | (($c2 >> 4) & 0o017)}]]
+        append r [Enc [expr {(($c2 << 2) & 0o074) | (($c3 >> 6) & 0o003)}]]
+        append r [Enc [expr {($c3 & 0o077)}]]
+    }
+    return $r
+}
+
+
+proc ::uuencode::Decode {s} {
+    if {[string length $s] == 0} {return ""}
+    set r {}
+    binary scan [pad $s] c* d
+
+    foreach {c0 c1 c2 c3} $d {
+        append r [format %c [expr {((($c0-0x20)&0x3F) << 2) & 0xFF
+                                   | ((($c1-0x20)&0x3F) >> 4) & 0xFF}]]
+        append r [format %c [expr {((($c1-0x20)&0x3F) << 4) & 0xFF
+                                   | ((($c2-0x20)&0x3F) >> 2) & 0xFF}]]
+        append r [format %c [expr {((($c2-0x20)&0x3F) << 6) & 0xFF
+                                   | (($c3-0x20)&0x3F) & 0xFF}]]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# C coded version of the Encode/Decode functions for base64c package.
+# -------------------------------------------------------------------------
+if {[package provide critcl] != {}} {
+    namespace eval ::uuencode {
+        critcl::ccode {
+            #include <string.h>
+            static unsigned char Enc(unsigned char c) {
+                return (c != 0) ? ((c & 0x3f) + 0x20) : 0x60;
+            }
+        }
+        critcl::ccommand CEncode {dummy interp objc objv} {
+            Tcl_Obj *inputPtr, *resultPtr;
+            Tcl_Size len, rlen, xtra;
+            unsigned char *input, *p, *r;
+
+            if (objc !=  2) {
+                Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */
+                return TCL_ERROR;
+            }
+
+            inputPtr = objv[1];
+            input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */
+            if (input == NULL) return TCL_ERROR;
+            if ((xtra = (3 - (len % 3))) != 3) {
+                if (Tcl_IsShared(inputPtr))
+                    inputPtr = Tcl_DuplicateObj(inputPtr);
+                input = Tcl_SetByteArrayLength(inputPtr, len + xtra); /* OK tcl9 */
+                memset(input + len, 0, xtra);
+                len += xtra;
+            }
+
+            rlen = (len / 3) * 4;
+            resultPtr = Tcl_NewObj();
+            r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */
+            memset(r, 0, rlen);
+
+            for (p = input; p < input + len; p += 3) {
+                char a, b, c;
+                a = *p; b = *(p+1), c = *(p+2);
+                *r++ = Enc(a >> 2);
+                *r++ = Enc(((a << 4) & 060) | ((b >> 4) & 017));
+                *r++ = Enc(((b << 2) & 074) | ((c >> 6) & 003));
+                *r++ = Enc(c & 077);
+            }
+            Tcl_SetObjResult(interp, resultPtr);
+            return TCL_OK;
+        }
+
+        critcl::ccommand CDecode {dummy interp objc objv} {
+            Tcl_Obj *inputPtr, *resultPtr;
+            Tcl_Size len, rlen, xtra;
+            unsigned char *input, *p, *r;
+
+            if (objc !=  2) {
+                Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */
+                return TCL_ERROR;
+            }
+
+            /* if input is not mod 4, extend it with nuls */
+            inputPtr = objv[1];
+            input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */
+            if (input == NULL) return TCL_ERROR;
+            if ((xtra = (4 - (len % 4))) != 4) {
+                if (Tcl_IsShared(inputPtr))
+                    inputPtr = Tcl_DuplicateObj(inputPtr);
+                input = Tcl_SetByteArrayLength(inputPtr, len + xtra); /* OK tcl9 */
+                memset(input + len, 0, xtra);
+                len += xtra;
+            }
+
+            /* output will be 1/3 smaller than input and a multiple of 3 */
+            rlen = (len / 4) * 3;
+            resultPtr = Tcl_NewObj();
+            r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */
+            memset(r, 0, rlen);
+
+            for (p = input; p < input + len; p += 4) {
+                char a, b, c, d;
+                a = *p; b = *(p+1), c = *(p+2), d = *(p+3);
+                *r++ = (((a - 0x20) & 0x3f) << 2) | (((b - 0x20) & 0x3f) >> 4);
+                *r++ = (((b - 0x20) & 0x3f) << 4) | (((c - 0x20) & 0x3f) >> 2);
+                *r++ = (((c - 0x20) & 0x3f) << 6) | (((d - 0x20) & 0x3f) );
+            }
+            Tcl_SetObjResult(interp, resultPtr);
+            return TCL_OK;
+        }
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# Description:
+#  Permit more tolerant decoding of invalid input strings by padding to
+#  a multiple of 4 bytes with nulls.
+# Result:
+#  Returns the input string - possibly padded with uuencoded null chars.
+#
+proc ::uuencode::pad {s} {
+    if {[set mod [expr {[string length $s] % 4}]] != 0} {
+        append s [string repeat "`" [expr {4 - $mod}]]
+    }
+    return $s
+}
+
+# -------------------------------------------------------------------------
+
+# If the Trf package is available then we shall use this by default but the
+# Tcllib implementations are always visible if needed (ie: for testing)
+if {[info commands ::uuencode::CDecode] != {}} {
+    # tcllib critcl package
+    interp alias {} ::uuencode::encode {} ::uuencode::CEncode
+    interp alias {} ::uuencode::decode {} ::uuencode::CDecode
+} elseif {[package provide Trf] != {}} {
+    proc ::uuencode::encode {s} {
+        return [::uuencode -mode encode -- $s]
+    }
+    proc ::uuencode::decode {s} {
+        return [::uuencode -mode decode -- [pad $s]]
+    }
+} else {
+    # pure-tcl then
+    interp alias {} ::uuencode::encode {} ::uuencode::Encode
+    interp alias {} ::uuencode::decode {} ::uuencode::Decode
+}
+
+# -------------------------------------------------------------------------
+
+proc ::uuencode::uuencode {args} {
+    array set opts {mode 0o0644 filename {} name {}}
+    set wrongargs "wrong \# args: should be\
+            \"uuencode ?-name string? ?-mode octal?\
+            (-file filename | ?--? string)\""
+    while {[string match -* [lindex $args 0]]} {
+        switch -glob -- [lindex $args 0] {
+            -f* {
+                if {[llength $args] < 2} {
+                    return -code error $wrongargs
+                }
+                set opts(filename) [lindex $args 1]
+                set args [lreplace $args 0 0]
+            }
+            -m* {
+                if {[llength $args] < 2} {
+                    return -code error $wrongargs
+                }
+                set opts(mode) [lindex $args 1]
+                set args [lreplace $args 0 0]
+            }
+            -n* {
+                if {[llength $args] < 2} {
+                    return -code error $wrongargs
+                }
+                set opts(name) [lindex $args 1]
+                set args [lreplace $args 0 0]
+            }
+            -- {
+                set args [lreplace $args 0 0]
+                break
+            }
+            default {
+                return -code error "bad option [lindex $args 0]:\
+                      must be -file, -mode, or -name"
+            }
+        }
+        set args [lreplace $args 0 0]
+    }
+
+    if {$opts(name) == {}} {
+        set opts(name) $opts(filename)
+    }
+    if {$opts(name) == {}} {
+        set opts(name) "data.dat"
+    }
+
+    if {$opts(filename) != {}} {
+        set f [open $opts(filename) r]
+        fconfigure $f -translation binary
+        set data [read $f]
+        close $f
+    } else {
+        if {[llength $args] != 1} {
+            return -code error $wrongargs
+        }
+        set data [lindex $args 0]
+    }
+
+    set r {}
+    append r [format "begin %o %s" $opts(mode) $opts(name)] "\n"
+    for {set n 0} {$n < [string length $data]} {incr n 45} {
+        set s [string range $data $n [expr {$n + 44}]]
+        append r [Enc [string length $s]]
+        append r [encode $s] "\n"
+    }
+    append r "`\nend"
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Perform uudecoding of a file or data. A file may contain more than one
+#  encoded data section so the result is a list where each element is a
+#  three element list of the provided filename, the suggested mode and the
+#  data itself.
+#
+proc ::uuencode::uudecode {args} {
+    array set opts {mode 0o0644 filename {}}
+    set wrongargs "wrong \# args: should be \"uudecode (-file filename | ?--? string)\""
+    while {[string match -* [lindex $args 0]]} {
+        switch -glob -- [lindex $args 0] {
+            -f* {
+                if {[llength $args] < 2} {
+                    return -code error $wrongargs
+                }
+                set opts(filename) [lindex $args 1]
+                set args [lreplace $args 0 0]
+            }
+            -- {
+                set args [lreplace $args 0 0]
+                break
+            }
+            default {
+                return -code error "bad option [lindex $args 0]:\
+                      must be -file"
+            }
+        }
+        set args [lreplace $args 0 0]
+    }
+
+    if {$opts(filename) != {}} {
+        set f [open $opts(filename) r]
+        set data [read $f]
+        close $f
+    } else {
+        if {[llength $args] != 1} {
+            return -code error $wrongargs
+        }
+        set data [lindex $args 0]
+    }
+
+    set state false
+    set result {}
+
+    foreach {line} [split $data "\n"] {
+        switch -exact -- $state {
+            false {
+                if {[regexp {^begin ([0-7]+) ([^\s]*)} $line \
+                         -> opts(mode) opts(name)]} {
+                    set state true
+                    set r {}
+                }
+            }
+
+            true {
+                if {[string match "end" $line]} {
+                    set state false
+                    lappend result [list $opts(name) $opts(mode) $r]
+                } else {
+                    scan $line %c c
+                    set n [expr {($c - 0x21)}]
+                    append r [string range \
+                                  [decode [string range $line 1 end]] 0 $n]
+                }
+            }
+        }
+    }
+
+    return $result
+}
+
+# -------------------------------------------------------------------------
+
+package provide uuencode 1.1.6
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
+

src/vendorlib_tcl9/tcllib2.0/base64/yencode.tcl

@@ -0,0 +1,309 @@
+# yencode.tcl - Copyright (C) 2002 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# Provide a Tcl only implementation of yEnc encoding algorithm
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+
+# FUTURE: Rework to allow switching between the tcl/critcl implementations.
+
+package require Tcl 8.5 9;                # tcl minimum version
+catch {package require crc32};          # tcllib 1.1
+catch {package require tcllibc};        # critcl enhancements for tcllib
+
+namespace eval ::yencode {
+    namespace export encode decode yencode ydecode
+}
+
+# -------------------------------------------------------------------------
+
+proc ::yencode::Encode {s} {
+    set r {}
+    binary scan $s c* d
+    foreach {c} $d {
+        set v [expr {($c + 42) % 256}]
+        if {$v == 0x00 || $v == 0x09 || $v == 0x0A
+            || $v == 0x0D || $v == 0x3D} {
+            append r "="
+            set v [expr {($v + 64) % 256}]
+        }
+        append r [format %c $v]
+    }
+    return $r
+}
+
+proc ::yencode::Decode {s} {
+    if {[string length $s] == 0} {return ""}
+    set r {}
+    set esc 0
+    binary scan $s c* d
+    foreach c $d {
+        if {$c == 61 && $esc == 0} {
+            set esc 1
+            continue
+        }
+        set v [expr {($c - 42) % 256}]
+        if {$esc} {
+            set v [expr {($v - 64) % 256}]
+            set esc 0
+        }
+        append r [format %c $v]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# C coded versions for critcl built base64c package
+# -------------------------------------------------------------------------
+
+if {[package provide critcl] != {}} {
+    namespace eval ::yencode {
+        critcl::ccode {
+            #include <string.h>
+        }
+        critcl::ccommand CEncode {dummy interp objc objv} {
+            Tcl_Obj *inputPtr, *resultPtr;
+            Tcl_Size len, rlen, xtra;
+            unsigned char *input, *p, *r, v;
+
+            if (objc !=  2) {
+                Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */
+                return TCL_ERROR;
+            }
+
+            /* fetch the input data */
+            inputPtr = objv[1];
+            input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */
+            if (input == NULL) return TCL_ERROR;
+
+            /* calculate the length of the encoded result */
+            rlen = len;
+            for (p = input; p < input + len; p++) {
+                v = (*p + 42) % 256;
+                if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D)
+                   rlen++;
+            }
+
+            /* allocate the output buffer */
+            resultPtr = Tcl_NewObj();
+            r = Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */
+
+            /* encode the input */
+            for (p = input; p < input + len; p++) {
+                v = (*p + 42) % 256;
+                if (v == 0 || v == 9 || v == 0x0A || v == 0x0D || v == 0x3D) {
+                    *r++ = '=';
+                    v = (v + 64) % 256;
+                }
+                *r++ = v;
+            }
+            Tcl_SetObjResult(interp, resultPtr);
+            return TCL_OK;
+        }
+
+        critcl::ccommand CDecode {dummy interp objc objv} {
+            Tcl_Obj *inputPtr, *resultPtr;
+            Tcl_Size len, rlen, esc;
+            unsigned char *input, *p, *r, v;
+
+            if (objc !=  2) {
+                Tcl_WrongNumArgs(interp, 1, objv, "data"); /* OK tcl9 */
+                return TCL_ERROR;
+            }
+
+            /* fetch the input data */
+            inputPtr = objv[1];
+            input = Tcl_GetBytesFromObj(interp, inputPtr, &len); /* OK tcl9 */
+            if (input == NULL) return TCL_ERROR;
+
+            /* allocate the output buffer */
+            resultPtr = Tcl_NewObj();
+            r = Tcl_SetByteArrayLength(resultPtr, len); /* OK tcl9 */
+
+            /* encode the input */
+            for (p = input, esc = 0, rlen = 0; p < input + len; p++) {
+                if (*p == 61 && esc == 0) {
+                    esc = 1;
+                    continue;
+                }
+                v = (*p - 42) % 256;
+                if (esc) {
+                    v = (v - 64) % 256;
+                    esc = 0;
+                }
+                *r++ = v;
+                rlen++;
+            }
+            Tcl_SetByteArrayLength(resultPtr, rlen); /* OK tcl9 */
+            Tcl_SetObjResult(interp, resultPtr);
+            return TCL_OK;
+        }
+    }
+}
+
+if {[info commands ::yencode::CEncode] != {}} {
+    interp alias {} ::yencode::encode {} ::yencode::CEncode
+    interp alias {} ::yencode::decode {} ::yencode::CDecode
+} else {
+    interp alias {} ::yencode::encode {} ::yencode::Encode
+    interp alias {} ::yencode::decode {} ::yencode::Decode
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Pop the nth element off a list. Used in options processing.
+#
+proc ::yencode::Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::yencode::yencode {args} {
+    array set opts {mode 0644 filename {} name {} line 128 crc32 1}
+    while {[string match -* [lindex $args 0]]} {
+        switch -glob -- [lindex $args 0] {
+            -f* { set opts(filename) [Pop args 1] }
+            -m* { set opts(mode) [Pop args 1] }
+            -n* { set opts(name) [Pop args 1] }
+            -l* { set opts(line) [Pop args 1] }
+            -c* { set opts(crc32) [Pop args 1] }
+            --  { Pop args ; break }
+            default {
+                set options [join [lsort [array names opts]] ", -"]
+                return -code error "bad option [lindex $args 0]:\
+                      must be -$options"
+            }
+        }
+        Pop args
+    }
+
+    if {$opts(name) == {}} {
+        set opts(name) $opts(filename)
+    }
+    if {$opts(name) == {}} {
+        set opts(name) "data.dat"
+    }
+    if {! [string is boolean $opts(crc32)]} {
+        return -code error "bad option -crc32: argument must be true or false"
+    }
+
+    if {$opts(filename) != {}} {
+        set f [open $opts(filename) rb]
+        fconfigure $f -translation binary
+        set data [read $f]
+        close $f
+    } else {
+        if {[llength $args] != 1} {
+            return -code error "wrong \# args: should be\
+                  \"yencode ?options? -file name | data\""
+        }
+        set data [lindex $args 0]
+    }
+
+    set opts(size) [string length $data]
+
+    set r {}
+    append r [format "=ybegin line=%d size=%d name=%s" \
+                  $opts(line) $opts(size) $opts(name)] "\n"
+
+    set ndx 0
+    while {$ndx < $opts(size)} {
+        set pln [string range $data $ndx [expr {$ndx + $opts(line) - 1}]]
+        set enc [encode $pln]
+        incr ndx [string length $pln]
+        append r $enc "\r\n"
+    }
+
+    append r [format "=yend size=%d" $ndx]
+    if {$opts(crc32)} {
+        append r " crc32=" [crc::crc32 -format %x $data]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+# Description:
+#  Perform ydecoding of a file or data. A file may contain more than one
+#  encoded data section so the result is a list where each element is a
+#  three element list of the provided filename, the file size and the
+#  data itself.
+#
+proc ::yencode::ydecode {args} {
+    array set opts {mode 0644 filename {} name default.bin}
+    while {[string match -* [lindex $args 0]]} {
+        switch -glob -- [lindex $args 0] {
+            -f* { set opts(filename) [Pop args 1] }
+            -- { Pop args ; break; }
+            default {
+                set options [join [lsort [array names opts]] ", -"]
+                return -code error "bad option [lindex $args 0]:\
+                      must be -$opts"
+            }
+        }
+        Pop args
+    }
+
+    if {$opts(filename) != {}} {
+        set f [open $opts(filename) r]
+        set data [read $f]
+        close $f
+    } else {
+        if {[llength $args] != 1} {
+            return -code error "wrong \# args: should be\
+                  \"ydecode ?options? -file name | data\""
+        }
+        set data [lindex $args 0]
+    }
+
+    set state false
+    set result {}
+
+    foreach {line} [split $data "\n"] {
+        set line [string trimright $line "\r\n"]
+        switch -exact -- $state {
+            false {
+                if {[string match "=ybegin*" $line]} {
+                    regexp {line=(\d+)} $line -> opts(line)
+                    regexp {size=(\d+)} $line -> opts(size)
+                    regexp {name=(\d+)} $line -> opts(name)
+
+                    if {$opts(name) == {}} {
+                        set opts(name) default.bin
+                    }
+
+                    set state true
+                    set r {}
+                }
+            }
+
+            true {
+                if {[string match "=yend*" $line]} {
+                    set state false
+                    lappend result [list $opts(name) $opts(size) $r]
+                } else {
+                    append r [decode $line]
+                }
+            }
+        }
+    }
+
+    return $result
+}
+
+# -------------------------------------------------------------------------
+
+package provide yencode 1.1.4
+
+# -------------------------------------------------------------------------
+#
+# Local variables:
+#   mode: tcl
+#   indent-tabs-mode: nil
+# End:
+

src/vendorlib_tcl9/tcllib2.0/bee/bee.tcl

@@ -0,0 +1,999 @@
+# bee.tcl --
+#
+#	BitTorrent Bee de- and encoder.
+#
+# Copyright (c) 2004 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# See the file license.terms.
+
+package require Tcl 8.5 9
+
+namespace eval ::bee {
+    # Encoder commands
+    namespace export \
+	    encodeString encodeNumber \
+	    encodeListArgs encodeList \
+	    encodeDictArgs encodeDict
+
+    # Decoder commands.
+    namespace export \
+	    decode \
+	    decodeChannel \
+	    decodeCancel \
+	    decodePush
+
+    # Channel decoders, reference to state information, keyed by
+    # channel handle.
+
+    variable  bee
+    array set bee {}
+
+    # Counter for generation of names for the state variables.
+
+    variable count 0
+
+    # State information for the channel decoders.
+
+    # stateN, with N an integer number counting from 0 on up.
+    # ...(chan)   Handle of channel the decoder is for.
+    # ...(cmd)    Command prefix, completion callback
+    # ...(exact)  Boolean flag, set for exact processing.
+    # ...(read)   Buffer for new characters to process.
+    # ...(type)   Type of current value (integer, string, list, dict)
+    # ...(value)  Buffer for assembling the current value.
+    # ...(pend)   Stack of pending 'value' buffers, for nested
+    #             containers.
+    # ...(state)  Current state of the decoding state machine.
+
+    # States of the finite automaton ...
+    # intro  - One char, type of value, or 'e' as stop of container.
+    # signum - sign or digit, for integer.
+    # idigit - digit, for integer, or 'e' as stop
+    # ldigit - digit, for length of string, or :
+    # data   - string data, 'get' characters.
+    # Containers via 'pend'.
+
+    #Debugging help, nesting level
+    #variable X 0
+}
+
+
+# ::bee::encodeString --
+#
+#	Encode a string to bee-format.
+#
+# Arguments:
+#	string	The string to encode.
+#
+# Results:
+#	The bee-encoded form of the string.
+
+proc ::bee::encodeString {string} {
+    return "[string length $string]:$string"
+}
+
+
+# ::bee::encodeNumber --
+#
+#	Encode an integer number to bee-format.
+#
+# Arguments:
+#	num	The integer number to encode.
+#
+# Results:
+#	The bee-encoded form of the integer number.
+
+proc ::bee::encodeNumber {num} {
+    ##nagelfar ignore
+    if {![string is integer -strict $num]} {
+	return -code error "Expected integer number, got \"$num\""
+    }
+
+    # The reformatting deals with hex, octal and other tcl
+    # representation of the value. In other words we normalize the
+    # string representation of the input value.
+
+    set num [format %d $num]
+    return "i${num}e"
+}
+
+
+# ::bee::encodeList --
+#
+#	Encode a list of bee-coded values to bee-format.
+#
+# Arguments:
+#	list	The list to encode.
+#
+# Results:
+#	The bee-encoded form of the list.
+
+proc ::bee::encodeList {list} {
+    return "l[join $list ""]e"
+}
+
+
+# ::bee::encodeListArgs --
+#
+#	Encode a variable list of bee-coded values to bee-format.
+#
+# Arguments:
+#	args	The values to encode.
+#
+# Results:
+#	The bee-encoded form of the list of values.
+
+proc ::bee::encodeListArgs {args} {
+    return [encodeList $args]
+}
+
+
+# ::bee::encodeDict --
+#
+#	Encode a dictionary of keys and bee-coded values to bee-format.
+#
+# Arguments:
+#	dict	The dictionary to encode.
+#
+# Results:
+#	The bee-encoded form of the dictionary.
+
+proc ::bee::encodeDict {dict} {
+    if {([llength $dict] % 2) == 1} {
+	return -code error "Expected even number of elements, got \"[llength $dict]\""
+    }
+    set temp [list]
+    foreach {k v} $dict {
+	lappend temp [list $k $v]
+    }
+    set res "d"
+    foreach item [lsort -index 0 $temp] {
+	foreach {k v} $item break
+	append res [encodeString $k]$v
+    }
+    append res "e"
+    return $res
+}
+
+
+# ::bee::encodeDictArgs --
+#
+#	Encode a variable dictionary of keys and bee-coded values to bee-format.
+#
+# Arguments:
+#	args	The keys and values to encode.
+#
+# Results:
+#	The bee-encoded form of the dictionary.
+
+proc ::bee::encodeDictArgs {args} {
+    return [encodeDict $args]
+}
+
+
+# ::bee::decode --
+#
+#	Decode a bee-encoded value and returns the embedded tcl
+#	value. For containers this recurses into the contained value.
+#
+# Arguments:
+#	value	The string containing the bee-encoded value to decode.
+#	evar	Optional. If set the name of the variable to store the
+#		index of the first character after the decoded value to.
+#	start	Optional. If set the index of the first character of the
+#		value to decode. Defaults to 0, i.e. the beginning of the
+#		string.
+#
+# Results:
+#	The tcl value embedded in the encoded string.
+
+proc ::bee::decode {value {evar {}} {start 0}} {
+    #variable X
+    #puts -nonewline "[string repeat "    " $X]decode @$start" ; flush stdout
+
+    if {$evar ne ""} {upvar 1 $evar end} else {set end _}
+
+    if {[string length $value] < ($start+2)} {
+	# This checked that the 'start' index is still in the string,
+	# and the end of the value most likely as well. Note that each
+	# encoded value consists of at least two characters (the
+	# bracketing characters for integer, list, and dict, and for
+	# string at least one digit length and the colon).
+
+	#puts \t[string length $value]\ <\ ($start+2)
+	return -code error "String not large enough for value"
+    }
+
+    set type [string index $value $start]
+
+    #puts -nonewline " $type=" ; flush stdout
+
+    if {$type eq "i"} {
+	# Extract integer
+	#puts -nonewline integer ; flush stdout
+
+	incr start ; # Skip over intro 'i'.
+	set end [string first e $value $start]
+	if {$end < 0} {
+	    return -code error "End of integer number not found"
+	}
+	incr end -1 ; # Get last character before closing 'e'.
+	set num [string range $value $start $end]
+	##nagelfar ignore
+	if {
+	    [regexp {^-0+$} $num] ||
+	    ![string is integer -strict $num] ||
+	    (([string length $num] > 1) && [string match 0* $num])
+	} {
+	    return -code error "Expected integer number, got \"$num\""
+	}
+	incr end 2 ; # Step after closing 'e' to the beginning of
+	# ........ ; # the next bee-value behind the current one.
+
+	#puts " ($num) @$end"
+	return [format %d $num]
+
+    } elseif {($type eq "l") || ($type eq "d")} {
+	#puts -nonewline $type\n ; flush stdout
+
+	# Extract list or dictionary, recursively each contained
+	# element. From the perspective of the decoder this is the
+	# same, the tcl representation of both is a list, and for a
+	# dictionary keys and values are also already in the correct
+	# order.
+
+	set result [list]
+	incr start ; # Step over intro 'e' to beginning of the first
+	# ........ ; # contained value, or behind the container (if
+	# ........ ; # empty).
+
+	set end $start
+	#incr X
+	while {[string index $value $start] ne "e"} {
+	    lappend result [decode $value end $start]
+	    set start $end
+	}
+	#incr X -1
+	incr end
+
+	#puts "[string repeat "    " $X]($result) @$end"
+
+	if {$type eq "d" && ([llength $result] % 2 == 1)} {
+	    return -code error "Dictionary has to be of even length"
+	}
+	return $result
+
+    } elseif {[string match {[0-9]} $type]} {
+	#puts -nonewline string ; flush stdout
+
+	# Extract string. First the length, bounded by a colon, then
+	# the appropriate number of characters.
+
+	set end [string first : $value $start]
+	if {$end < 0} {
+	    return -code error "End of string length not found"
+	}
+	incr end -1
+	set length [string range $value $start $end]
+	incr end 2 ;# Skip to beginning of the string after the colon
+
+	##nagelfar ignore
+	if {![string is integer -strict $length]} {
+	    return -code error "Expected integer number for string length, got \"$length\""
+	} elseif {$length < 0} {
+	    # This cannot happen. To happen "-" has to be first character,
+	    # and this is caught as unknown bee-type.
+	    return -code error "Illegal negative string length"
+	} elseif {($end + $length) > [string length $value]} {
+	    return -code error "String not large enough for value"
+	}
+
+	#puts -nonewline \[$length\] ; flush stdout
+	set length [format %d $length]
+	if {$length > 0} {
+	    set  start $end
+	    incr end $length
+	    incr end -1
+	    set result [string range $value $start $end]
+	    incr end
+	} else {
+	    set result ""
+	}
+
+	#puts " ($result) @$end"
+	return $result
+
+    } else {
+	return -code error "Unknown bee-type \"$type\""
+    }
+}
+
+# ::bee::decodeIndices --
+#
+#	Similar to 'decode', but does not return the decoded tcl values,
+#	but a structure containing the start- and end-indices for all
+#	values in the structure.
+#
+# Arguments:
+#	value	The string containing the bee-encoded value to decode.
+#	evar	Optional. If set the name of the variable to store the
+#		index of the first character after the decoded value to.
+#	start	Optional. If set the index of the first character of the
+#		value to decode. Defaults to 0, i.e. the beginning of the
+#		string.
+#
+# Results:
+#	The structure of the value, with indices and types for all
+#	contained elements.
+
+proc ::bee::decodeIndices {value {evar {}} {start 0}} {
+    #variable X
+    #puts -nonewline "[string repeat "    " $X]decode @$start" ; flush stdout
+
+    if {$evar ne ""} {upvar 1 $evar end} else {set end _}
+
+    if {[string length $value] < ($start+2)} {
+	# This checked that the 'start' index is still in the string,
+	# and the end of the value most likely as well. Note that each
+	# encoded value consists of at least two characters (the
+	# bracketing characters for integer, list, and dict, and for
+	# string at least one digit length and the colon).
+
+	#puts \t[string length $value]\ <\ ($start+2)
+	return -code error "String not large enough for value"
+    }
+
+    set type [string index $value $start]
+
+    #puts -nonewline " $type=" ; flush stdout
+
+    if {$type eq "i"} {
+	# Extract integer
+	#puts -nonewline integer ; flush stdout
+
+	set begin $start
+
+	incr start ; # Skip over intro 'i'.
+	set end [string first e $value $start]
+	if {$end < 0} {
+	    return -code error "End of integer number not found"
+	}
+	incr end -1 ; # Get last character before closing 'e'.
+	set num [string range $value $start $end]
+	##nagelfar ignore
+	if {
+	    [regexp {^-0+$} $num] ||
+	    ![string is integer -strict $num] ||
+	    (([string length $num] > 1) && [string match 0* $num])
+	} {
+	    return -code error "Expected integer number, got \"$num\""
+	}
+	incr end
+	set stop $end
+	incr end 1 ; # Step after closing 'e' to the beginning of
+	# ........ ; # the next bee-value behind the current one.
+
+	#puts " ($num) @$end"
+	return [list integer $begin $stop]
+
+    } elseif {$type eq "l"} {
+	#puts -nonewline $type\n ; flush stdout
+
+	# Extract list, recursively each contained element.
+
+	set result [list]
+
+	lappend result list $start @
+
+	incr start ; # Step over intro 'e' to beginning of the first
+	# ........ ; # contained value, or behind the container (if
+	# ........ ; # empty).
+
+	set end $start
+	#incr X
+
+	set contained [list]
+	while {[string index $value $start] ne "e"} {
+	    lappend contained [decodeIndices $value end $start]
+	    set start $end
+	}
+	lappend result $contained
+	#incr X -1
+	set stop $end
+	incr end
+
+	#puts "[string repeat "    " $X]($result) @$end"
+
+	return [lreplace $result 2 2 $stop]
+
+    } elseif {($type eq "l") || ($type eq "d")} {
+	#puts -nonewline $type\n ; flush stdout
+
+	# Extract dictionary, recursively each contained element.
+
+	set result [list]
+
+	lappend result dict $start @
+
+	incr start ; # Step over intro 'e' to beginning of the first
+	# ........ ; # contained value, or behind the container (if
+	# ........ ; # empty).
+
+	set end $start
+	set atkey 1
+	#incr X
+
+	set contained [list]
+	set val       [list]
+	while {[string index $value $start] ne "e"} {
+	    if {$atkey} {
+		lappend contained [decode $value {} $start]
+		lappend val       [decodeIndices $value end $start]
+		set atkey 0
+	    } else {
+		lappend val       [decodeIndices $value end $start]
+		lappend contained $val
+		set val [list]
+		set atkey 1
+	    }
+	    set start $end
+	}
+	lappend result $contained
+	#incr X -1
+	set stop $end
+	incr end
+
+	#puts "[string repeat "    " $X]($result) @$end"
+
+	if {[llength $result] % 2 == 1} {
+	    return -code error "Dictionary has to be of even length"
+	}
+	return [lreplace $result 2 2 $stop]
+
+    } elseif {[string match {[0-9]} $type]} {
+	#puts -nonewline string ; flush stdout
+
+	# Extract string. First the length, bounded by a colon, then
+	# the appropriate number of characters.
+
+	set end [string first : $value $start]
+	if {$end < 0} {
+	    return -code error "End of string length not found"
+	}
+	incr end -1
+	set length [string range $value $start $end]
+	incr end 2 ;# Skip to beginning of the string after the colon
+
+	##nagelfar ignore
+	if {![string is integer -strict $length]} {
+	    return -code error "Expected integer number for string length, got \"$length\""
+	} elseif {$length < 0} {
+	    # This cannot happen. To happen "-" has to be first character,
+	    # and this is caught as unknown bee-type.
+	    return -code error "Illegal negative string length"
+	} elseif {($end + $length) > [string length $value]} {
+	    return -code error "String not large enough for value"
+	}
+
+	set length [format %d $length]
+	#puts -nonewline \[$length\] ; flush stdout
+	incr end -1
+	if {$length > 0} {
+	    incr end $length
+	    set stop $end
+	} else {
+	    set stop $end
+	}
+	incr end
+
+	#puts " ($result) @$end"
+	return [list string $start $stop]
+
+    } else {
+	return -code error "Unknown bee-type \"$type\""
+    }
+}
+
+
+# ::bee::decodeChannel --
+#
+#	Attach decoder for a bee-value to a channel. See the
+#	documentation for details.
+#
+# Arguments:
+#	chan			Channel to attach to.
+#	-command cmdprefix	Completion callback. Required.
+#	-exact			Keep running after completion.
+#	-prefix data		Seed for decode buffer.
+#
+# Results:
+#	A token to use when referring to the decoder.
+#	For example when canceling it.
+
+proc ::bee::decodeChannel {chan args} {
+    variable bee
+    if {[info exists bee($chan)]} {
+	return -code error "bee-Decoder already active for channel"
+    }
+
+    # Create state and token.
+
+    variable  count
+    variable  [set st state$count]
+    array set $st {}
+    set       bee($chan) $st
+    upvar 0  $st state
+    incr count
+
+    # Initialize the decoder state, process the options. When
+    # encountering errors here destroy the half-baked state before
+    # throwing the message.
+
+    set       state(chan) $chan
+    array set state {
+	exact  0
+	type   ?
+	read   {}
+	value  {}
+	pend   {}
+	state  intro
+	get    1
+    }
+
+    while {[llength $args]} {
+	set option [lindex $args 0]
+	set args [lrange $args 1 end]
+	if {$option eq "-command"} {
+	    if {![llength $args]} {
+		unset bee($chan)
+		unset state
+		return -code error "Missing value for option -command."
+	    }
+	    set state(cmd) [lindex $args 0]
+	    set args       [lrange $args 1 end]
+
+	} elseif {$option eq "-prefix"} {
+	    if {![llength $args]} {
+		unset bee($chan)
+		unset state
+		return -code error "Missing value for option -prefix."
+	    }
+	    set state(read) [lindex $args 0]
+	    set args        [lrange $args 1 end]
+
+	} elseif {$option eq "-exact"} {
+	    set state(exact) 1
+	} else {
+	    unset bee($chan)
+	    unset state
+	    return -code error "Illegal option \"$option\",\
+		    expected \"-command\", \"-prefix\", or \"-keep\""
+	}
+    }
+
+    if {![info exists state(cmd)]} {
+	unset bee($chan)
+	unset state
+	return -code error "Missing required completion callback."
+    }
+
+    # Set up the processing of incoming data.
+
+    fileevent $chan readable [list ::bee::Process $chan $bee($chan)]
+
+    # Return the name of the state array as token.
+    return $bee($chan)
+}
+
+# ::bee::Parse --
+#
+#	Internal helper. Fileevent handler for a decoder.
+#	Parses input and handles both error and eof conditions.
+#
+# Arguments:
+#	token	The decoder to run on its input.
+#
+# Results:
+#	None.
+
+proc ::bee::Process {chan token} {
+    if {[catch {Parse $token} msg]} {
+	# Something failed. Destroy and report.
+	Command $token error $msg
+	return
+    }
+
+    if {[eof $chan]} {
+	# Having data waiting, either in the input queue, or in the
+	# output stack (of nested containers) is a failure. Report
+	# this instead of the eof.
+
+	variable $token
+	upvar 0  $token state
+
+	if {
+	    [string length $state(read)] ||
+	    [llength       $state(pend)] ||
+	    [string length $state(value)] ||
+	    ($state(state) ne "intro")
+	} {
+	    Command $token error "Incomplete value at end of channel"
+	} else {
+	    Command $token eof
+	}
+    }
+    return
+}
+
+# ::bee::Parse --
+#
+#	Internal helper. Reading from the channel and parsing the input.
+#	Uses a hardwired state machine.
+#
+# Arguments:
+#	token	The decoder to run on its input.
+#
+# Results:
+#	None.
+
+proc ::bee::Parse {token} {
+    variable $token
+    upvar 0  $token state
+    upvar 0  state(state) current
+    upvar 0  state(read)  input
+    upvar 0  state(type)  type
+    upvar 0  state(value) value
+    upvar 0  state(pend)  pend
+    upvar 0  state(exact) exact
+    upvar 0  state(get)   get
+    set chan $state(chan)
+
+    #puts Parse/$current
+
+    if {!$exact} {
+	# Add all waiting characters to the buffer so that we can process as
+	# much as is possible in one go.
+	append input [read $chan]
+    } else {
+	# Exact reading. Usually one character, but when in the data
+	# section for a string value we know for how many characters
+	# we are looking for.
+
+	append input [read $chan $get]
+    }
+
+    # We got nothing, do nothing.
+    if {![string length $input]} return
+
+
+    if {$current eq "data"} {
+	# String data, this can be done faster, as we read longer
+	# sequences of characters for this.
+	set l [string length $input]
+	if {$l < $get} {
+	    # Not enough, wait for more.
+	    append value $input
+	    incr get -$l
+	    return
+	} elseif {$l == $get} {
+	    # Got all, exactly. Prepare state machine for next value.
+
+	    if {[Complete $token $value$input]} return
+
+	    set current intro
+	    set get 1
+	    set value ""
+	    set input ""
+
+	    return
+	} else {
+	    # Got more than required (only for !exact).
+
+	    incr get -1
+	    if {[Complete $token $value[string range $input 0 $get]]} {return}
+
+	    incr get
+	    set input [string range $input $get end]
+	    set get 1
+	    set value ""
+	    set current intro
+	    # This now falls into the loop below.
+	}
+    }
+
+    set where 0
+    set n [string length $input]
+
+    #puts Parse/$n
+
+    while {$where < $n} {
+	# Hardwired state machine. Get current character.
+	set ch [string index $input $where]
+
+	#puts Parse/@$where/$current/$ch/
+	if {$current eq "intro"} {
+	    # First character of a value.
+
+	    if {$ch eq "i"} {
+		# Begin reading integer.
+		set type    integer
+		set current signum
+	    } elseif {$ch eq "l"} {
+		# Begin a list.
+		set type list
+		lappend pend list {}
+		#set current intro
+
+	    } elseif {$ch eq "d"} {
+		# Begin a dictionary.
+		set type dict
+		lappend pend dict {}
+		#set current intro
+
+	    } elseif {$ch eq "e"} {
+		# Close a container. Throw an error if there is no
+		# container to close.
+
+		if {![llength $pend]} {
+		    return -code error "End of container outside of container."
+		}
+
+		set v    [lindex $pend end]
+		set t    [lindex $pend end-1]
+		set pend [lrange $pend 0 end-2]
+
+		if {$t eq "dict" && ([llength $v] % 2 == 1)} {
+		    return -code error "Dictionary has to be of even length"
+		}
+
+		if {[Complete $token $v]} {return}
+		set current intro
+
+	    } elseif {[string match {[0-9]} $ch]} {
+		# Begin reading a string, length section first.
+		set type    string
+		set current ldigit
+		set value   $ch
+
+	    } else {
+		# Unknown type. Throw error.
+		return -code error "Unknown bee-type \"$ch\""
+	    }
+
+	    # To next character.
+	    incr where
+	} elseif {$current eq "signum"} {
+	    # Integer number, a minus sign, or a digit.
+	    if {[string match {[-0-9]} $ch]} {
+		append value $ch
+		set current idigit
+	    } else {
+		return -code error "Syntax error in integer,\
+			expected sign or digit, got \"$ch\""
+	    }
+	    incr where
+
+	} elseif {$current eq "idigit"} {
+	    # Integer number, digit or closing 'e'.
+
+	    if {[string match {[-0-9]} $ch]} {
+		append value $ch
+	    } elseif {$ch eq "e"} {
+		# Integer closes. Validate and report.
+		#puts validate
+		##nagelfar ignore
+		if {
+		    [regexp {^-0+$} $value] ||
+		    ![string is integer -strict $value] ||
+		    (([string length $value] > 1) && [string match 0* $value])
+		} {
+		    return -code error "Expected integer number, got \"$value\""
+		}
+		set value [format %d $value]
+		if {[Complete $token $value]} {return}
+		set value ""
+		set current intro
+	    } else {
+		return -code error "Syntax error in integer,\
+			expected digit, or 'e', got \"$ch\""
+	    }
+	    incr where
+
+	} elseif {$current eq "ldigit"} {
+	    # String, length section, digit, or :
+
+	    if {[string match {[-0-9]} $ch]} {
+		append value $ch
+
+	    } elseif {$ch eq ":"} {
+		# Length section closes, validate,
+		# then perform data processing.
+
+		set num $value
+		##nagelfar ignore
+		if {
+		    [regexp {^-0+$} $num] ||
+		    ![string is integer -strict $num] ||
+		    (([string length $num] > 1) && [string match 0* $num])
+		} {
+		    return -code error "Expected integer number as string length, got \"$num\""
+		}
+		set num [format %d $num]
+		set value ""
+
+		# We may have already part of the data in
+		# memory. Process that piece before looking for more.
+
+		incr where
+		set have [expr {$n - $where}]
+		if {$num < $have} {
+		    # More than enough in the buffer.
+
+		    set  end $where
+		    incr end $num
+		    incr end -1
+
+		    if {[Complete $token [string range $input $where $end]]} {return}
+
+		    set where   $end ;# Further processing behind the string.
+		    set current intro
+
+		} elseif {$num == $have} {
+		    # Just enough. 
+
+		    if {[Complete $token [string range $input $where end]]} {return}
+
+		    set where   $n
+		    set current intro
+		} else {
+		    # Not enough. Initialize value with the data we
+		    # have (after the colon) and stop processing for
+		    # now.
+
+		    set value   [string range $input $where end]
+		    set current data
+		    set get     $num
+		    set input   ""
+		    return
+		}
+	    } else {
+		return -code error "Syntax error in string length,\
+			expected digit, or ':', got \"$ch\""
+	    }
+	    incr where
+	} else {
+	    # unknown state = internal error
+	    return -code error "Unknown decoder state \"$current\", internal error"
+	}
+    }
+
+    set input ""
+    return
+}
+
+# ::bee::Command --
+#
+#	Internal helper. Runs the decoder command callback.
+#
+# Arguments:
+#	token	The decoder invoking its callback
+#	how	Which method to invoke (value, error, eof)
+#	args	Arguments for the method.
+#
+# Results:
+#	A boolean flag. Set if further processing has to stop.
+
+proc ::bee::Command {token how args} {
+    variable $token
+    upvar 0  $token state
+
+    #puts Report/$token/$how/$args/
+
+    set cmd  $state(cmd)
+    set chan $state(chan)
+
+    # We catch the fileevents because they will fail when this is
+    # called from the 'Close'. The channel will already be gone in
+    # that case.
+
+    set stop 0
+    if {($how eq "error") || ($how eq "eof")} {
+	variable bee
+
+	set stop 1
+	fileevent $chan readable {}
+	unset bee($chan)
+	unset state
+
+	if {$how eq "eof"} {
+	    #puts \tclosing/$chan
+	    close $chan
+	}
+    }
+
+    lappend cmd $how $token
+    foreach a $args {lappend cmd $a}
+    uplevel #0 $cmd
+
+    if {![info exists state]} {
+	# The decoder token was killed by the callback, stop
+	# processing.
+	set stop 1
+    }
+
+    #puts /$stop/[file channels]
+    return $stop
+}
+
+# ::bee::Complete --
+#
+#	Internal helper. Reports a completed value.
+#
+# Arguments:
+#	token	The decoder reporting the value.
+#	value	The value to report.
+#
+# Results:
+#	A boolean flag. Set if further processing has to stop.
+
+proc ::bee::Complete {token value} {
+    variable $token
+    upvar 0  $token state
+    upvar 0   state(pend) pend
+
+    if {[llength $pend]} {
+	# The value is part of a container. Add the value to its end
+	# and keep processing.
+
+	set pend [lreplace $pend end end \
+		[linsert [lindex $pend end] end \
+		$value]]
+
+	# Don't stop.
+	return 0
+    }
+
+    # The value is at the top, report it. The callback determines if
+    # we keep processing.
+
+    return [Command $token value $value]
+}
+
+# ::bee::decodeCancel --
+#
+#	Destroys the decoder referenced by the token.
+#
+# Arguments:
+#	token	The decoder to destroy.
+#
+# Results:
+#	None.
+
+proc ::bee::decodeCancel {token} {
+    variable bee
+    variable $token
+    upvar 0  $token state
+    unset bee($state(chan))
+    unset state
+    return
+}
+
+# ::bee::decodePush --
+#
+#	Push data into the decoder input buffer.
+#
+# Arguments:
+#	token	The decoder to extend.
+#	string	The characters to add.
+#
+# Results:
+#	None.
+
+proc ::bee::decodePush {token string} {
+    variable $token
+    upvar 0  $token state
+    append state(read) $string
+    return
+}
+
+
+package provide bee 0.3

src/vendorlib_tcl9/tcllib2.0/bee/pkgIndex.tcl

@@ -0,0 +1,4 @@
+# Tcl package index file, version 1.1
+
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {return}
+package ifneeded bee 0.3 [list source [file join $dir bee.tcl]]

src/vendorlib_tcl9/tcllib2.0/bench/bench.tcl

@@ -0,0 +1,556 @@
+# bench.tcl --
+#
+#	Management of benchmarks.
+#
+# Copyright (c) 2005-2008 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# library derived from runbench.tcl application (C) Jeff Hobbs.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+# ### ### ### ######### ######### ######### ###########################
+## Requisites - Packages and namespace for the commands and data.
+
+package require Tcl 8.5 9
+package require logger
+package require csv
+package require struct::matrix
+package require report
+
+namespace eval ::bench      {}
+namespace eval ::bench::out {}
+
+# @mdgen OWNER: libbench.tcl
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Benchmark execution
+
+# ::bench::run --
+#
+#	Run a series of benchmarks.
+#
+# Arguments:
+#	...
+#
+# Results:
+#	Dictionary.
+
+proc ::bench::run {args} {
+    log::debug [linsert $args 0 ::bench::run]
+
+    # -errors  0|1         default 1, propagate errors in benchmarks
+    # -threads <num>       default 0, no threads, #threads to use
+    # -match  <pattern>    only run tests matching this pattern
+    # -rmatch <pattern>    only run tests matching this pattern
+    # -iters  <num>        default 1000, max#iterations for any benchmark
+    # -pkgdir <dir>        Defaults to nothing, regular bench invokation.
+
+    # interps - dict (path -> version)
+    # files   - list (of files)
+
+    # Process arguments ......................................
+    # Defaults first, then overides by the user
+
+    set errors  1    ; # Propagate errors
+    set threads 0    ; # Do not use threads
+    set match   {}   ; # Do not exclude benchmarks based on glob pattern
+    set rmatch  {}   ; # Do not exclude benchmarks based on regex pattern
+    set iters   1000 ; # Limit #iterations for any benchmark
+    set pkgdirs {}   ; # List of dirs to put in front of auto_path in the
+                       # bench interpreters. Default: nothing.
+
+    while {[string match "-*" [set opt [lindex $args 0]]]} {
+	set val [lindex $args 1]
+	switch -exact -- $opt {
+	    -errors {
+		if {![string is boolean -strict $val]} {
+		    return -code error "Expected boolean, got \"$val\""
+		}
+		set errors $val
+	    }
+	    -threads {
+		##nagelfar ignore
+		if {![string is integer -strict $val] || ($val < 0)} {
+		    return -code error "Expected int >= 0, got \"$val\""
+		}
+		set threads [format %d $val]
+	    }
+	    -match {
+		set match [lindex $args 1]
+	    }
+	    -rmatch {
+		set rmatch [lindex $args 1]
+	    }
+	    -iters {
+		##nagelfar ignore
+		if {![string is integer -strict $val] || ($val <= 0)} {
+		    return -code error "Expected int > 0, got \"$val\""
+		}
+		set iters [format %d $val]
+	    }
+	    -pkgdir {
+		CheckPkgDirArg  $val
+		lappend pkgdirs $val
+	    }
+	    default {
+		return -code error "Unknown option \"$opt\", should -errors, -threads, -match, -rmatch, or -iters"
+	    }
+	}
+	set args [lrange $args 2 end]
+    }
+    if {[llength $args] != 2} {
+	return -code error "wrong\#args, should be: ?options? interp files"
+    }
+    foreach {interps files} $args break
+
+    # Run the benchmarks .....................................
+
+    array set DATA {}
+
+    if {![llength $pkgdirs]} {
+	# No user specified package directories => Simple run.
+	foreach {ip ver} $interps {
+	    Invoke $ip $ver {} ;# DATA etc passed via upvar.
+	}
+    } else {
+	# User specified package directories.
+	foreach {ip ver} $interps {
+	    foreach pkgdir $pkgdirs {
+		Invoke $ip $ver $pkgdir ;# DATA etc passed via upvar.
+	    }
+	}
+    }
+
+    # Benchmark data ... Structure, dict (key -> value)
+    #
+    # Key          || Value
+    # ============ ++ =========================================
+    # interp IP    -> Version. Shell IP was used to run benchmarks. IP is
+    #                 the path to the shell.
+    #
+    # desc DESC    -> "". DESC is description of an executed benchmark.
+    #
+    # usec DESC IP -> Result. Result of benchmark DESC when run by the
+    #                 shell IP. Usually time in microseconds, but can be
+    #                 a special code as well (ERR, BAD_RES).
+    # ============ ++ =========================================
+
+    return [array get DATA]
+}
+
+# ::bench::locate --
+#
+#	Locate interpreters on the pathlist, based on a pattern.
+#
+# Arguments:
+#	...
+#
+# Results:
+#	List of paths.
+
+proc ::bench::locate {pattern paths} {
+    # Cache of executables already found.
+    array set var {}
+    set res {}
+
+    foreach path $paths {
+	foreach ip [glob -nocomplain [file join $path $pattern]] {
+            set ip [file normalize $ip]
+
+	    # Follow soft-links to the actual executable.
+	    while {[string equal link [file type $ip]]} {
+		set link [file readlink $ip]
+		if {[string match relative [file pathtype $link]]} {
+		    set ip [file join [file dirname $ip] $link]
+		} else {
+		    set ip $link
+		}
+	    }
+
+	    if {
+		[file executable $ip] && ![info exists var($ip)]
+	    } {
+		if {[catch {exec $ip << "exit"} dummy]} {
+		    log::debug "$ip: $dummy"
+		    continue
+		}
+		set var($ip) .
+		lappend res $ip
+	    }
+	}
+    }
+
+    return $res
+}
+
+# ::bench::versions --
+#
+#	Take list of interpreters, find their versions.
+#	Removes all interps for which it cannot do so.
+#
+# Arguments:
+#	List of interpreters (paths)
+#
+# Results:
+#	dictionary: interpreter -> version.
+
+proc ::bench::versions {interps} {
+    set res {}
+    foreach ip $interps {
+	if {[catch {
+	    exec $ip << {puts [info patchlevel] ; exit}
+	} patchlevel]} {
+	    log::debug "$ip: $patchlevel"
+	    continue
+	}
+
+	lappend res [list $patchlevel $ip]
+    }
+
+    # -uniq 8.4-ism, replaced with use of array.
+    array set tmp {}
+    set resx {}
+    foreach item [lsort -dictionary -decreasing -index 0 $res] {
+	foreach {p ip} $item break
+	if {[info exists tmp($p)]} continue
+	set tmp($p) .
+	lappend resx $ip $p
+    }
+
+    return $resx
+}
+
+# ::bench::merge --
+#
+#	Take the data of several benchmark runs and merge them into
+#	one data set.
+#
+# Arguments:
+#	One or more data sets to merge
+#
+# Results:
+#	The merged data set.
+
+proc ::bench::merge {args} {
+    if {[llength $args] == 1} {
+	return [lindex $args 0]
+    }
+
+    array set DATA {}
+    foreach data $args {
+	array set DATA $data
+    }
+    return [array get DATA]
+}
+
+# ::bench::norm --
+#
+#	Normalize the time data in the dataset, using one of the
+#	columns as reference.
+#
+# Arguments:
+#	Data to normalize
+#	Index of reference column
+#
+# Results:
+#	The normalized data set.
+
+proc ::bench::norm {data col} {
+
+    ##nagelfar ignore
+    if {![string is integer -strict $col]} {
+	return -code error "Ref.column: Expected integer, but got \"$col\""
+    }
+    set col [format %d $col]
+    if {$col < 1} {
+	return -code error "Ref.column out of bounds"
+    }
+
+    array set DATA $data
+    set ipkeys [array names DATA interp*]
+
+    if {$col > [llength $ipkeys]} {
+	return -code error "Ref.column out of bounds"
+    }
+    incr col -1
+    set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1]
+
+    foreach key [array names DATA] {
+	if {[string match "desc*"   $key]} continue
+	if {[string match "interp*" $key]} continue
+
+	foreach {_ desc ip} $key break
+	if {[string equal $ip $refip]}      continue
+
+	set v $DATA($key)
+	if {![string is double -strict $v]} continue
+
+	if {![info exists DATA([list usec $desc $refip])]} {
+	    # We cannot normalize, we do not keep the time value.
+	    # The row will be shown, empty.
+	    set DATA($key) ""
+	    continue
+	}
+	set vref $DATA([list usec $desc $refip])
+
+	if {![string is double -strict $vref]} continue
+
+	set DATA($key) [expr {$v/double($vref)}]
+    }
+
+    foreach key [array names DATA [list * $refip]] {
+	if {![string is double -strict $DATA($key)]} continue
+	set DATA($key) 1
+    }
+
+    return [array get DATA]
+}
+
+# ::bench::edit --
+#
+#	Change the 'path' of an interp to a user-defined value.
+#
+# Arguments:
+#	Data to edit
+#	Index of column to change
+#	The value replacing the current path
+#
+# Results:
+#	The changed data set.
+
+proc ::bench::edit {data col new} {
+
+    ##nagelfar ignore
+    if {![string is integer -strict $col]} {
+	return -code error "Ref.column: Expected integer, but got \"$col\""
+    }
+    set col [format %d $col]
+    if {$col < 1} {
+	return -code error "Ref.column out of bounds"
+    }
+
+    array set DATA $data
+    set ipkeys [array names DATA interp*]
+
+    if {$col > [llength $ipkeys]} {
+	return -code error "Ref.column out of bounds"
+    }
+    incr col -1
+    set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1]
+
+    if {[string equal $new $refip]} {
+	# No change, quick return
+	return $data
+    }
+
+    set refkey [list interp $refip]
+    set DATA([list interp $new]) $DATA($refkey)
+    unset                         DATA($refkey)
+
+    foreach key [array names DATA [list * $refip]] {
+	if {![string equal [lindex $key 0] "usec"]} continue
+	foreach {__ desc ip} $key break
+	set DATA([list usec $desc $new]) $DATA($key)
+	unset                             DATA($key)
+    }
+
+    return [array get DATA]
+}
+
+# ::bench::del --
+#
+#	Remove the data for an interp.
+#
+# Arguments:
+#	Data to edit
+#	Index of column to remove
+#
+# Results:
+#	The changed data set.
+
+proc ::bench::del {data col} {
+    ##nagelfar ignore
+    if {![string is integer -strict $col]} {
+	return -code error "Ref.column: Expected integer, but got \"$col\""
+    }
+    set col [format %d $col]
+    if {$col < 1} {
+	return -code error "Ref.column out of bounds"
+    }
+
+    array set DATA $data
+    set ipkeys [array names DATA interp*]
+
+    if {$col > [llength $ipkeys]} {
+	return -code error "Ref.column out of bounds"
+    }
+    incr col -1
+    set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1]
+
+    unset DATA([list interp $refip])
+
+    # Do not use 'array unset'. Keep 8.2 clean.
+    foreach key [array names DATA [list * $refip]] {
+	if {![string equal [lindex $key 0] "usec"]} continue
+	unset DATA($key)
+    }
+
+    return [array get DATA]
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Result formatting.
+
+# ::bench::out::raw --
+#
+#	Format the result of a benchmark run.
+#	Style: Raw data.
+#
+# Arguments:
+#	DATA dict
+#
+# Results:
+#	String containing the formatted DATA.
+
+proc ::bench::out::raw {data} {
+    return $data
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Internal commands
+
+proc ::bench::CheckPkgDirArg {path {expected {}}} {
+    # Allow empty string, special.
+    if {![string length $path]} return
+
+    if {![file isdirectory $path]} {
+	return -code error \
+	    "The path \"$path\" is not a directory."
+    }
+    if {![file readable $path]} {
+	return -code error \
+	    "The path \"$path\" is not readable."
+    }
+}
+
+proc ::bench::Invoke {ip ver pkgdir} {
+    variable self
+    # Import remainder of the current configuration/settings.
+
+    upvar 1 DATA DATA match match rmatch rmatch \
+	iters iters errors errors threads threads \
+	files files
+
+    if {[string length $pkgdir]} {
+	log::info "Benchmark $ver ($pkgdir) $ip"
+	set idstr "$ip ($pkgdir)"
+    } else {
+	log::info "Benchmark $ver $ip"
+	set idstr $ip
+    }
+
+    set DATA([list interp $idstr]) $ver
+
+    set cmd [list $ip [file join $self libbench.tcl] \
+		 -match   $match   \
+		 -rmatch  $rmatch  \
+		 -iters   $iters   \
+		 -interp  $ip      \
+		 -errors  $errors  \
+		 -threads $threads \
+		 -pkgdir  $pkgdir  \
+		]
+
+    # Determine elapsed time per file, logged.
+    set start [clock seconds]
+
+    array set tmp {}
+
+    if {$threads} {
+	foreach f $files { lappend cmd $f }
+	if {[catch {
+	    close [Process [open |$cmd r+]]
+	} output]} {
+	    if {$errors} {
+		error $::errorInfo
+	    }
+	}
+    } else {
+	foreach file $files {
+	    log::info [file tail $file]
+	    if {[catch {
+		close [Process [open |[linsert $cmd end $file] r+]]
+	    } output]} {
+		if {$errors} {
+		    error $::errorInfo
+		} else {
+		    continue
+		}
+	    }
+	}
+    }
+
+    foreach desc [array names tmp] {
+	set DATA([list desc $desc]) {}
+	set DATA([list usec $desc $idstr]) $tmp($desc)
+    }
+
+    unset tmp
+    set elapsed [expr {[clock seconds] - $start}]
+
+    set hour [expr {$elapsed / 3600}]
+    set min  [expr {$elapsed / 60}]
+    set sec  [expr {$elapsed % 60}]
+    log::info " [format %.2d:%.2d:%.2d $hour $min $sec] elapsed"
+    return
+}
+
+
+proc ::bench::Process {pipe} {
+    while {1} {
+	if {[eof  $pipe]} break
+	if {[gets $pipe line] < 0} break
+	# AK: FUTURE: Log all lines?!
+	#puts |$line|
+	set line [string trim $line]
+	if {[string equal $line ""]} continue
+
+	Result
+	Feedback
+	# Unknown lines are printed. Future: Callback?!
+	log::info $line
+    }
+    return $pipe
+}
+
+proc ::bench::Result {} {
+    upvar 1 line line
+    if {[lindex $line 0] ne "RESULT"} return
+    upvar 2 tmp tmp
+    foreach {_ desc result} $line break
+    set tmp($desc) $result
+    return -code continue
+}
+
+proc ::bench::Feedback {} {
+    upvar 1 line line
+    if {[lindex $line 0] ne "LOG"} return
+    # AK: Future - Run through callback?!
+    log::info [lindex $line 1]
+    return -code continue
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Initialize internal data structures.
+
+namespace eval ::bench {
+    variable self [file join [pwd] [file dirname [info script]]]
+
+    logger::init bench
+    logger::import -force -all -namespace log bench
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Ready to run
+
+package provide bench 0.6

src/vendorlib_tcl9/tcllib2.0/bench/bench_read.tcl

@@ -0,0 +1,162 @@
+# bench_read.tcl --
+#
+#	Management of benchmarks, reading results in various formats.
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# library derived from runbench.tcl application (C) Jeff Hobbs.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# RCS: @(#) $Id: bench_read.tcl,v 1.3 2006/06/13 23:20:30 andreas_kupries Exp $
+
+# ### ### ### ######### ######### ######### ###########################
+## Requisites - Packages and namespace for the commands and data.
+
+package require Tcl 8.5 9
+package require csv
+
+namespace eval ::bench::in {}
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Result reading
+
+# ::bench::in::read --
+#
+#	Read a bench result in any of the raw/csv/text formats
+#
+# Arguments:
+#	path to file to read
+#
+# Results:
+#	DATA dictionary, internal representation of the bench results.
+
+proc ::bench::in::read {file} {
+
+    set f [open $file r]
+    set head [gets $f]
+
+    if {![string match "# -\\*- tcl -\\*- bench/*" $head]} {
+	return -code error "Bad file format, not a benchmark file"
+    } else {
+	regexp {bench/(.*)$} $head -> format
+
+	switch -exact -- $format {
+	    raw - csv - text {
+		set res [RD$format $f]
+	    }
+	    default {
+		return -code error "Bad format \"$val\", expected text, csv, or raw"
+	    }
+	}
+    }
+    close $f
+    return $res
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Internal commands
+
+proc ::bench::in::RDraw {chan} {
+    return [string trimright [::read $chan]]
+}
+
+proc ::bench::in::RDcsv {chan} {
+    # Lines                                     Format
+    # First line is number of interpreters #n.  int
+    # Next to 1+n is interpreter data.          id,ver,path
+    # Beyond is benchmark results.              id,desc,res1,...,res#n
+
+    array set DATA {}
+
+    # #Interp ...
+
+    set nip [lindex [csv::split [gets $chan]] 0]
+
+    # Interp data ...
+
+    set iplist {}
+    for {set i 0} {$i < $nip} {incr i} {
+	foreach {__ ver ip} [csv::split [gets $chan]] break
+
+	set DATA([list interp $ip]) $ver
+	lappend iplist $ip
+    }
+
+    # Benchmark data ...
+
+    while {[gets $chan line] >= 0} {
+	set line [string trim $line]
+	if {$line == {}} break
+	set line [csv::split $line]
+	set desc [lindex $line 1]
+
+	set DATA([list desc $desc]) {}
+	foreach val [lrange $line 2 end] ip $iplist {
+	    if {$val == {}} continue
+	    set DATA([list usec $desc $ip]) $val
+	}
+    }
+
+    return [array get DATA]
+}
+
+proc ::bench::in::RDtext {chan} {
+    array set DATA {}
+
+    # Interp data ...
+
+    # Empty line     - ignore
+    # "id: ver path" - interp data.
+    # Empty line     - separator before benchmark data.
+
+    set n 0
+    set iplist {}
+    while {[gets $chan line] >= 0} {
+	set line [string trim $line]
+	if {$line == {}} {
+	    incr n
+	    if {$n == 2} break
+	    continue
+	}
+
+	regexp {[^:]+: ([^ ]+) (.*)$} $line -> ver ip
+	set DATA([list interp $ip]) $ver
+	lappend iplist $ip
+    }
+
+    # Benchmark data ...
+
+    # '---' -> Ignore.
+    # '|' column separators. Remove spaces around it. Then treat line
+    # as CSV data with a particular separator.
+    # Ignore the INTERP line.
+
+    while {[gets $chan line] >= 0} {
+	set line [string trim $line]
+	if {$line == {}}                     continue
+	if {[string match "+---*"    $line]} continue
+	if {[string match "*INTERP*" $line]} continue
+
+	regsub -all "\\| +" $line {|} line
+	regsub -all " +\\|" $line {|} line
+	set line [csv::split [string trim $line |] |]
+	set desc [lindex $line 1]
+
+	set DATA([list desc $desc]) {}
+	foreach val [lrange $line 2 end] ip $iplist {
+	    if {$val == {}} continue
+	    set DATA([list usec $desc $ip]) $val
+	}
+    }
+
+    return [array get DATA]
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Initialize internal data structures.
+
+# ### ### ### ######### ######### ######### ###########################
+## Ready to run
+
+package provide bench::in 0.2

src/vendorlib_tcl9/tcllib2.0/bench/bench_wcsv.tcl

@@ -0,0 +1,101 @@
+# bench_wtext.tcl --
+#
+#	Management of benchmarks, formatted text.
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# library derived from runbench.tcl application (C) Jeff Hobbs.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# RCS: @(#) $Id: bench_wcsv.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $
+
+# ### ### ### ######### ######### ######### ###########################
+## Requisites - Packages and namespace for the commands and data.
+
+package require Tcl 8.5 9
+package require csv
+
+namespace eval ::bench::out {}
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Benchmark execution
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Result formatting.
+
+# ::bench::out::csv --
+#
+#	Format the result of a benchmark run.
+#	Style: CSV
+#
+# Arguments:
+#	DATA dict
+#
+# Results:
+#	String containing the formatted DATA.
+
+proc ::bench::out::csv {data} {
+    array set DATA $data
+    set CSV {}
+
+    # 1st record:              #shells
+    # 2nd record to #shells+1: Interpreter data (id, version, path)
+    # #shells+2 to end:        Benchmark data (id,desc,result1,...,result#shells)
+
+    # --- --- ----
+    # #interpreters used
+
+    set ipkeys [array names DATA interp*]
+    lappend CSV [csv::join [list [llength $ipkeys]]]
+
+    # --- --- ----
+    # Table 1: Interpreter information.
+
+    set n 1
+    set iplist {}
+    foreach key [lsort -dict $ipkeys] {
+	set ip [lindex $key 1]
+	lappend CSV [csv::join [list $n $DATA($key) $ip]]
+	set DATA($key) $n
+	incr n
+	lappend iplist $ip
+    }
+
+    # --- --- ----
+    # Table 2: Benchmark information
+
+    set dlist {}
+    foreach key [lsort -dict -index 1 [array names DATA desc*]] {
+	lappend dlist [lindex $key 1]
+    }
+
+    set n 1
+    foreach desc $dlist { 
+	set record {}
+	lappend record $n
+	lappend record $desc
+	foreach ip $iplist {
+	    if {[catch {
+		lappend record $DATA([list usec $desc $ip])
+	    }]} {
+		lappend record {}
+	    }
+	}
+	lappend CSV [csv::join $record]
+	incr n
+    }
+
+    return [join $CSV \n]
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Internal commands
+
+# ### ### ### ######### ######### ######### ###########################
+## Initialize internal data structures.
+
+# ### ### ### ######### ######### ######### ###########################
+## Ready to run
+
+package provide bench::out::csv 0.1.3

src/vendorlib_tcl9/tcllib2.0/bench/bench_wtext.tcl

@@ -0,0 +1,165 @@
+# bench_wtext.tcl --
+#
+#	Management of benchmarks, formatted text.
+#
+# Copyright (c) 2005 by Andreas Kupries <andreas_kupries@users.sourceforge.net>
+# library derived from runbench.tcl application (C) Jeff Hobbs.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# 
+# RCS: @(#) $Id: bench_wtext.tcl,v 1.4 2007/01/21 23:29:06 andreas_kupries Exp $
+
+# ### ### ### ######### ######### ######### ###########################
+## Requisites - Packages and namespace for the commands and data.
+
+package require Tcl 8.5 9
+package require struct::matrix
+package require report
+
+namespace eval ::bench::out {}
+
+# ### ### ### ######### ######### ######### ###########################
+## Public API - Result formatting.
+
+# ::bench::out::text --
+#
+#	Format the result of a benchmark run.
+#	Style: TEXT
+#
+#	General structure like CSV, but nicely formatted and aligned
+#	columns.
+#
+# Arguments:
+#	DATA dict
+#
+# Results:
+#	String containing the formatted DATA.
+
+proc ::bench::out::text {data} {
+    array set DATA $data
+    set LINES {}
+
+    # 1st line to #shells: Interpreter data (id, version, path)
+    # #shells+1 to end:    Benchmark data (id,desc,result1,...,result#shells)
+
+    lappend LINES {}
+
+    # --- --- ----
+    # Table 1: Interpreter information.
+
+    set ipkeys [array names DATA interp*]
+    set n 1
+    set iplist {}
+    set vlen 0
+    foreach key [lsort -dict $ipkeys] {
+	lappend iplist [lindex $key 1]
+	incr n
+	set l [string length $DATA($key)]
+	if {$l > $vlen} {set vlen $l}
+    }
+    set idlen [string length $n]
+
+    set dlist {}
+    set n 1
+    foreach key [lsort -dict -index 1 [array names DATA desc*]] {
+	lappend dlist [lindex $key 1]
+	incr n
+    }
+    set didlen [string length $n]
+
+    set n 1
+    set record [list "" INTERP]
+    foreach ip $iplist {
+	set v $DATA([list interp $ip])
+	lappend LINES " [PADL $idlen $n]: [PADR $vlen $v] $ip"
+	lappend record $n
+	incr n
+    }
+
+    lappend LINES {}
+
+    # --- --- ----
+    # Table 2: Benchmark information
+
+    set m [struct::matrix m]
+    $m add columns [expr {2 + [llength $iplist]}]
+    $m add row $record
+
+    set n 1
+    foreach desc $dlist { 
+	set     record [list $n]
+	lappend record $desc
+
+	foreach ip $iplist {
+	    if {[catch {
+		set val $DATA([list usec $desc $ip])
+	    }]} {
+		set val {}
+	    }
+	    if {[string is double -strict $val]} {
+		lappend record [format %.2f $val]
+	    } else {
+		lappend record [format %s   $val]
+	    }
+	}
+	$m add row $record
+	incr n
+    }
+
+    ::report::defstyle simpletable {} {
+	data	set [split "[string repeat "| "   [columns]]|"]
+	top	set [split "[string repeat "+ - " [columns]]+"]
+	bottom	set [top get]
+	top	enable
+	bottom	enable
+
+	set c [columns]
+	justify 0 right
+	pad 0 both
+
+	if {$c > 1} {
+	    justify 1 left
+	    pad 1 both
+	}
+	for {set i 2} {$i < $c} {incr i} {
+	    justify $i right
+	    pad $i both
+	}
+    }
+    ::report::defstyle captionedtable {{n 1}} {
+	simpletable
+	topdata   set [data get]
+	topcapsep set [top get]
+	topcapsep enable
+	tcaption $n
+    }
+
+    set r [report::report r [$m columns] style captionedtable]
+    lappend LINES [$m format 2string $r]
+    $m destroy
+    $r destroy
+
+    return [join $LINES \n]
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Internal commands
+
+proc ::bench::out::PADL {max str} {
+    format "%${max}s" $str
+    #return "[PAD $max $str]$str"
+}
+
+proc ::bench::out::PADR {max str} {
+    format "%-${max}s" $str
+    #return "$str[PAD $max $str]"
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Initialize internal data structures.
+
+# ### ### ### ######### ######### ######### ###########################
+## Ready to run
+
+package provide bench::out::text 0.1.3

src/vendorlib_tcl9/tcllib2.0/bench/libbench.tcl

@@ -0,0 +1,561 @@
+# -*- tcl -*-
+# libbench.tcl ?(<option> <value>)...? <benchFile>...
+#
+# This file has to have code that works in any version of Tcl that
+# the user would want to benchmark.
+#
+# RCS: @(#) $Id: libbench.tcl,v 1.4 2008/07/02 23:34:06 andreas_kupries Exp $
+#
+# Copyright (c) 2000-2001 Jeffrey Hobbs.
+# Copyright (c) 2007      Andreas Kupries
+#
+
+# This code provides the supporting commands for the execution of a
+# benchmark files. It is actually an application and is exec'd by the
+# management code.
+
+# Options:
+# -help				Print usage message.
+# -rmatch <regexp-pattern>	Run only tests whose description matches the pattern.
+# -match  <glob-pattern>	Run only tests whose description matches the pattern.
+# -interp <name>		Name of the interp running the benchmarks.
+# -thread <num>                 Invoke threaded benchmarks, number of threads to use.
+# -errors <boolean>             Throw errors, or not.
+
+# Note: If both -match and -rmatch are specified then _both_
+# apply. I.e. a benchmark will be run if and only if it matches both
+# patterns.
+
+# Application activity and results are communicated to the highlevel
+# management via text written to stdout. Each line written is a list
+# and has one of the following forms:
+#
+# __THREADED <version>     - Indicates threaded mode, and version
+#                            of package Thread in use.
+#
+# Sourcing {<desc>: <res>} - Benchmark <desc> has started.
+#                            <res> is the result from executing
+#                            it once (compilation of body.)
+#
+# Sourcing <file>          - Benchmark file <file> starts execution.
+#
+# <desc> <res>             - Result of a benchmark.
+#
+# The above implies that no benchmark may use the strings 'Sourcing'
+# or '__THREADED' as their description.
+
+# We will put our data into these named globals.
+
+global BENCH bench
+
+# 'BENCH' contents:
+#
+# - ERRORS  : Boolean flag. If set benchmark output mismatches are
+#             reported by throwing an error. Otherwise they are simply
+#             listed as BAD_RES. Default true. Can be set/reset via
+#             option -errors.
+#
+# - MATCH   : Match pattern, see -match, default empty, aka everything
+#             matches.
+#
+# - RMATCH  : Match pattern, see -rmatch, default empty, aka
+#             everything matches.
+#
+# - OUTFILE : Name of output file, default is special value "stdout".
+# - OUTFID  : Channel for output.
+#
+# The outfile cannot be set by the caller, thus output is always
+# written to stdout.
+#
+# - FILES   : List of benchmark files to run.
+#
+# - ITERS   : Number of iterations to run a benchmark body, default
+#             1000. Can be overridden by the individual benchmarks.
+#
+# - THREADS : Number of threads to use. 0 signals no threading.
+#             Limited to number of files if there are less files than
+#             requested threads.
+#
+# - EXIT    : Boolean flag. True when appplication is run by wish, for
+#             special exit processing. ... Actually always true.
+#
+# - INTERP  : Name of the interpreter running the benchmarks. Is the
+#             executable running this code. Can be overridden via the
+#             command line option -interp.
+#
+# - uniqid  : Counter for 'bench_tmpfile' to generate unique names of
+#             tmp files.
+#
+# - us      : Thread id of main thread.
+#
+# - inuse   : Number of threads active, present and relevant only in
+#             threaded mode.
+#
+# - file    : Currently executed benchmark file. Relevant only in
+#             non-threaded mode.
+
+#
+# 'bench' contents.
+
+# Benchmark results, mapping from the benchmark descriptions to their
+# results. Usually time in microseconds, but the following special
+# values can occur:
+#
+# - BAD_RES    - Result from benchmark body does not match expectations.
+# - ERR        - Benchmark body aborted with an error.
+# - Any string - Forced by error code 666 to pass to management.
+
+#
+# We claim all procedures starting with bench*
+#
+
+# bench_tmpfile --
+#
+#   Return a temp file name that can be modified at will
+#
+# Arguments:
+#   None
+#
+# Results:
+#   Returns file name
+#
+proc bench_tmpfile {} {
+    global tcl_platform env BENCH
+    if {![info exists BENCH(uniqid)]} { set BENCH(uniqid) 0 }
+    set base "tclbench[incr BENCH(uniqid)].dat"
+    if {[info exists tcl_platform(platform)]} {
+	if {$tcl_platform(platform) == "unix"} {
+	    return "/tmp/$base"
+	} elseif {$tcl_platform(platform) == "windows"} {
+	    return [file join $env(TEMP) $base]
+	} else {
+	    return $base
+	}
+    } else {
+	# The Good Ol' Days (?) when only Unix support existed
+	return "/tmp/$base"
+    }
+}
+
+# bench_rm --
+#
+#   Remove a file silently (no complaining)
+#
+# Arguments:
+#   args	Files to delete
+#
+# Results:
+#   Returns nothing
+#
+proc bench_rm {args} {
+    foreach file $args {
+	if {[info tclversion] > 7.4} {
+	    catch {file delete $file}
+	} else {
+	    catch {exec /bin/rm $file}
+	}
+    }
+}
+
+proc bench_puts {args} {
+    eval [linsert $args 0 FEEDBACK]
+    return
+}
+
+# bench --
+#
+#   Main bench procedure.
+#   The bench test is expected to exit cleanly.  If an error occurs,
+#   it will be thrown all the way up.  A bench proc may return the
+#   special code 666, which says take the string as the bench value.
+#   This is usually used for N/A feature situations.
+#
+# Arguments:
+#
+#   -pre	script to run before main timed body
+#   -body	script to run as main timed body
+#   -post	script to run after main timed body
+#   -ipre	script to run before timed body, per iteration of the body.
+#   -ipost	script to run after timed body, per iteration of the body.
+#   -desc	message text
+#   -iterations	<#>
+#
+# Note:
+#
+#   Using -ipre and/or -ipost will cause us to compute the average
+#   time ourselves, i.e. 'time body 1' n times. Required to ensure
+#   that prefix/post operation are executed, yet not timed themselves.
+#
+# Results:
+#
+#   Returns nothing
+#
+# Side effects:
+#
+#   Sets up data in bench global array
+#
+proc bench {args} {
+    global BENCH bench errorInfo errorCode
+
+    # -pre script
+    # -body script
+    # -desc msg
+    # -post script
+    # -ipre script
+    # -ipost script
+    # -iterations <#>
+    array set opts {
+	-pre	{}
+	-body	{}
+	-desc	{}
+	-post	{}
+	-ipre	{}
+	-ipost	{}
+    }
+    set opts(-iter) $BENCH(ITERS)
+    while {[llength $args]} {
+	set key [lindex $args 0]
+	switch -glob -- $key {
+	    -res*	{ set opts(-res)  [lindex $args 1] }
+	    -pr*	{ set opts(-pre)  [lindex $args 1] }
+	    -po*	{ set opts(-post) [lindex $args 1] }
+	    -ipr*	{ set opts(-ipre)  [lindex $args 1] }
+	    -ipo*	{ set opts(-ipost) [lindex $args 1] }
+	    -bo*	{ set opts(-body) [lindex $args 1] }
+	    -de*	{ set opts(-desc) [lindex $args 1] }
+	    -it*	{
+		# Only change the iterations when it is smaller than
+		# the requested default
+		set val [lindex $args 1]
+		if {$opts(-iter) > $val} { set opts(-iter) $val }
+	    }
+	    default {
+		error "unknown option $key"
+	    }
+	}
+	set args [lreplace $args 0 1]
+    }
+
+    FEEDBACK "Running <$opts(-desc)>"
+
+    if {($BENCH(MATCH) != "") && ![string match $BENCH(MATCH) $opts(-desc)]} {
+	return
+    }
+    if {($BENCH(RMATCH) != "") && ![regexp $BENCH(RMATCH) $opts(-desc)]} {
+	return
+    }
+    if {$opts(-pre) != ""} {
+	uplevel \#0 $opts(-pre)
+    }
+    if {$opts(-body) != ""} {
+	# always run it once to remove compile phase confusion
+	if {$opts(-ipre) != ""} {
+	    uplevel \#0 $opts(-ipre)
+	}
+	set code [catch {uplevel \#0 $opts(-body)} res]
+	if {$opts(-ipost) != ""} {
+	    uplevel \#0 $opts(-ipost)
+	}
+	if {!$code && [info exists opts(-res)] \
+		&& [string compare $opts(-res) $res]} {
+	    if {$BENCH(ERRORS)} {
+		return -code error "Result was:\n$res\nResult\
+			should have been:\n$opts(-res)"
+	    } else {
+		set res "BAD_RES"
+	    }
+	    #set bench($opts(-desc)) $res
+	    RESULT $opts(-desc) $res
+	} else {
+	    if {($opts(-ipre) != "") || ($opts(-ipost) != "")} {
+		# We do the averaging on our own, to allow untimed
+		# pre/post execution per iteration. We catch and
+		# handle problems in the pre/post code as if
+		# everything was executed as one block (like it would
+		# be in the other path). We are using floating point
+		# to avoid integer overflow, easily happening when
+		# accumulating a high number (iterations) of large
+		# integers (microseconds).
+
+		set total 0.0
+		for {set i 0} {$i < $opts(-iter)} {incr i} {
+		    set code 0
+		    if {$opts(-ipre) != ""} {
+			set code [catch {uplevel \#0 $opts(-ipre)} res]
+			if {$code} break
+		    }
+		    set code [catch {uplevel \#0 [list time $opts(-body) 1]} res]
+		    if {$code} break
+		    set total [expr {$total + [lindex $res 0]}]
+		    if {$opts(-ipost) != ""} {
+			set code [catch {uplevel \#0 $opts(-ipost)} res]
+			if {$code} break
+		    }
+		}
+		if {!$code} {
+		    set res [list [expr {int ($total/$opts(-iter))}] microseconds per iteration]
+		}
+	    } else {
+		set code [catch {uplevel \#0 \
+			[list time $opts(-body) $opts(-iter)]} res]
+	    }
+	    if {!$BENCH(THREADS)} {
+		if {$code == 0} {
+		    # Get just the microseconds value from the time result
+		    set res [lindex $res 0]
+		} elseif {$code != 666} {
+		    # A 666 result code means pass it through to the bench
+		    # suite. Otherwise throw errors all the way out, unless
+		    # we specified not to throw errors (option -errors 0 to
+		    # libbench).
+		    if {$BENCH(ERRORS)} {
+			return -code $code -errorinfo $errorInfo \
+				-errorcode $errorCode
+		    } else {
+			set res "ERR"
+		    }
+		}
+		#set bench($opts(-desc)) $res
+		RESULT $opts(-desc) $res
+	    } else {
+		# Threaded runs report back asynchronously
+		thread::send $BENCH(us) \
+			[list thread_report $opts(-desc) $code $res]
+	    }
+	}
+    }
+    if {($opts(-post) != "") && [catch {uplevel \#0 $opts(-post)} err] \
+	    && $BENCH(ERRORS)} {
+	return -code error "post code threw error:\n$err"
+    }
+    return
+}
+
+proc RESULT {desc time} {
+    global BENCH
+    puts $BENCH(OUTFID) [list RESULT $desc $time]
+    return
+}
+
+proc FEEDBACK {text} {
+    global BENCH
+    puts $BENCH(OUTFID) [list LOG $text]
+    return
+}
+
+
+proc usage {} {
+    set me [file tail [info script]]
+    puts stderr "Usage: $me ?options?\
+	    \n\t-help			# print out this message\
+	    \n\t-rmatch <regexp>	# only run tests matching this pattern\
+	    \n\t-match <glob>		# only run tests matching this pattern\
+	    \n\t-interp	<name>		# name of interp (tries to get it right)\
+	    \n\t-thread	<num>		# number of threads to use\
+	    \n\tfileList		# files to benchmark"
+    exit 1
+}
+
+#
+# Process args
+#
+if {[catch {set BENCH(INTERP) [info nameofexec]}]} {
+    set BENCH(INTERP) $argv0
+}
+foreach {var val} {
+	ERRORS		1
+	MATCH		{}
+	RMATCH		{}
+	OUTFILE		stdout
+	FILES		{}
+	ITERS		1000
+	THREADS		0
+        PKGDIR          {}
+	EXIT		"[info exists tk_version]"
+} {
+    if {![info exists BENCH($var)]} {
+	set BENCH($var) [subst $val]
+    }
+}
+set BENCH(EXIT) 1
+
+if {[llength $argv]} {
+    while {[llength $argv]} {
+	set key [lindex $argv 0]
+	switch -glob -- $key {
+	    -help*	{ usage }
+	    -err*	{ set BENCH(ERRORS)  [lindex $argv 1] }
+	    -int*	{ set BENCH(INTERP)  [lindex $argv 1] }
+	    -rmat*	{ set BENCH(RMATCH)  [lindex $argv 1] }
+	    -mat*	{ set BENCH(MATCH)   [lindex $argv 1] }
+	    -iter*	{ set BENCH(ITERS)   [lindex $argv 1] }
+	    -thr*	{ set BENCH(THREADS) [lindex $argv 1] }
+            -pkg*       { set BENCH(PKGDIR)  [lindex $argv 1] }
+	    default {
+		foreach arg $argv {
+		    if {![file exists $arg]} { usage }
+		    lappend BENCH(FILES) $arg
+		}
+		break
+	    }
+	}
+	set argv [lreplace $argv 0 1]
+    }
+}
+
+if {[string length $BENCH(PKGDIR)]} {
+    set auto_path [linsert $auto_path 0 $BENCH(PKGDIR)]
+}
+
+if {$BENCH(THREADS)} {
+    # We have to be able to load threads if we want to use threads, and
+    # we don't want to create more threads than we have files.
+    if {[catch {package require Thread}]} {
+	set BENCH(THREADS) 0
+    } elseif {[llength $BENCH(FILES)] < $BENCH(THREADS)} {
+	set BENCH(THREADS) [llength $BENCH(FILES)]
+    }
+}
+
+rename exit exit.true
+proc exit args {
+    error "called \"exit $args\" in benchmark test"
+}
+
+if {[string compare $BENCH(OUTFILE) stdout]} {
+    set BENCH(OUTFID) [open $BENCH(OUTFILE) w]
+} else {
+    set BENCH(OUTFID) stdout
+}
+
+#
+# Everything that gets output must be in pairwise format, because
+# the data will be collected in via an 'array set'.
+#
+
+if {$BENCH(THREADS)} {
+    # Each file must run in it's own thread because of all the extra
+    # header stuff they have.
+    #set DEBUG 1
+    proc thread_one {{id 0}} {
+	global BENCH
+	set file [lindex $BENCH(FILES) 0]
+	set BENCH(FILES) [lrange $BENCH(FILES) 1 end]
+	if {[file exists $file]} {
+	    incr BENCH(inuse)
+	    FEEDBACK [list Sourcing $file]
+	    if {$id} {
+		set them $id
+	    } else {
+		set them [thread::create]
+		thread::send -async $them { load {} Thread }
+		thread::send -async $them \
+			[list array set BENCH [array get BENCH]]
+		thread::send -async $them \
+			[list proc bench_tmpfile {} [info body bench_tmpfile]]
+		thread::send -async $them \
+			[list proc bench_rm {args} [info body bench_rm]]
+		thread::send -async $them \
+			[list proc bench {args} [info body bench]]
+	    }
+	    if {[info exists ::DEBUG]} {
+		FEEDBACK "SEND [clock seconds] thread $them $file INUSE\
+		$BENCH(inuse) of $BENCH(THREADS)"
+	    }
+	    thread::send -async $them [list source $file]
+	    thread::send -async $them \
+		    [list thread::send $BENCH(us) [list thread_ready $them]]
+	    #thread::send -async $them { thread::unwind }
+	}
+    }
+
+    proc thread_em {} {
+	global BENCH
+	while {[llength $BENCH(FILES)]} {
+	    if {[info exists ::DEBUG]} {
+		FEEDBACK "THREAD ONE [lindex $BENCH(FILES) 0]"
+	    }
+	    thread_one
+	    if {$BENCH(inuse) >= $BENCH(THREADS)} {
+		break
+	    }
+	}
+    }
+
+    proc thread_ready {id} {
+	global BENCH
+
+	incr BENCH(inuse) -1
+	if {[llength $BENCH(FILES)]} {
+	    if {[info exists ::DEBUG]} {
+		FEEDBACK "SEND ONE [clock seconds] thread $id"
+	    }
+	    thread_one $id
+	} else {
+	    if {[info exists ::DEBUG]} {
+		FEEDBACK "UNWIND thread $id"
+	    }
+	    thread::send -async $id { thread::unwind }
+	}
+    }
+
+    proc thread_report {desc code res} {
+	global BENCH bench errorInfo errorCode
+
+	if {$code == 0} {
+	    # Get just the microseconds value from the time result
+	    set res [lindex $res 0]
+	} elseif {$code != 666} {
+	    # A 666 result code means pass it through to the bench suite.
+	    # Otherwise throw errors all the way out, unless we specified
+	    # not to throw errors (option -errors 0 to libbench).
+	    if {$BENCH(ERRORS)} {
+		return -code $code -errorinfo $errorInfo \
+			-errorcode $errorCode
+	    } else {
+		set res "ERR"
+	    }
+	}
+	#set bench($desc) $res
+	RESULT $desc $res
+    }
+
+    proc thread_finish {{delay 4000}} {
+	global BENCH bench
+	set val [expr {[llength [thread::names]] > 1}]
+	#set val [expr {$BENCH(inuse)}]
+	if {$val} {
+	    after $delay [info level 0]
+	} else {
+	    if {0} {foreach desc [array names bench] {
+		RESULT $desc $bench($desc)
+	    }}
+	    if {$BENCH(EXIT)} {
+		exit.true ; # needed for Tk tests
+	    }
+	}
+    }
+
+    set BENCH(us) [thread::id]
+    set BENCH(inuse) 0 ; # num threads in use
+    FEEDBACK [list __THREADED [package provide Thread]]
+
+    thread_em
+    thread_finish
+    vwait forever
+} else {
+    foreach BENCH(file) $BENCH(FILES) {
+	if {[file exists $BENCH(file)]} {
+	    FEEDBACK [list Sourcing $BENCH(file)]
+	    source $BENCH(file)
+	}
+    }
+
+    if {0} {foreach desc [array names bench] {
+	RESULT $desc $bench($desc)
+    }}
+
+    if {$BENCH(EXIT)} {
+	exit.true ; # needed for Tk tests
+    }
+}

src/vendorlib_tcl9/tcllib2.0/bench/pkgIndex.tcl

@@ -0,0 +1,7 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {
+    return
+}
+package ifneeded bench            0.6   [list source [file join $dir bench.tcl]]
+package ifneeded bench::out::text 0.1.3 [list source [file join $dir bench_wtext.tcl]]
+package ifneeded bench::out::csv  0.1.3 [list source [file join $dir bench_wcsv.tcl]]
+package ifneeded bench::in        0.2   [list source [file join $dir bench_read.tcl]]

src/vendorlib_tcl9/tcllib2.0/bibtex/bibtex.tcl

@@ -0,0 +1,501 @@
+#####
+#
+# "BibTeX parser"
+# http://wiki.tcl.tk/13719
+#
+# Tcl code harvested on:   7 Mar 2005, 23:55 GMT
+# Wiki page last updated: ???
+#
+#####
+
+# bibtex.tcl --
+#
+#      A basic parser for BibTeX bibliography databases.
+#
+# Copyright (c) 2005 Neil Madden.
+# Copyright (c) 2005 Andreas Kupries.
+# License: Tcl/BSD style.
+
+### NOTES
+###
+### Need commands to introspect parser state. Especially the string
+### map (for testing of 'addStrings', should be useful in general as
+### well).
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5 9
+package require cmdline
+
+# ### ### ### ######### ######### #########
+## Implementation: Public API
+
+namespace eval ::bibtex {}
+
+# bibtex::parse --
+#
+#	Parse a bibtex file.
+#
+# parse ?options? ?bibtex?
+
+proc ::bibtex::parse {args} {
+    variable data
+    variable id
+
+    # Argument processing
+    if {[llength $args] < 1} {
+	set err "[lindex [info level 0] 0] ?options? ?bibtex?"
+	return -code error "wrong # args: should be \"$err\""
+    }
+
+    array set state {}
+    GetOptions $args state
+
+    # Initialize the parser state from the options, fill in default
+    # values, and handle the input according the specified mode.
+
+    set token bibtex[incr id]
+    foreach {k v} [array get state] {
+	set data($token,$k) $v
+    }
+
+    if {$state(stream)} {
+	# Text not in memory
+	if {!$state(bg)} {
+	    # Text from a channel, no async processing. We read everything
+	    # into memory and the handle it as before.
+
+	    set blockmode [fconfigure $state(-channel) -blocking]
+	    fconfigure $state(-channel) -blocking 1
+	    set data($token,buffer) [read $state(-channel)]
+	    fconfigure $state(-channel) -blocking $blockmode
+
+	    # Tell upcoming processing that the text is in memory.
+	    set state(stream) 0
+	} else {
+	    # Text from a channel, and processing is async. Create an
+	    # event handler for the incoming data.
+
+	    set data($token,done) 0
+	    fileevent $state(-channel) readable \
+		    [list ::bibtex::ReadChan $token]
+
+	    # Initialize the parser internal result buffer if we use plain
+	    # -command, and not the SAX api.
+	    if {!$state(sax)} {
+		set data($token,result) {}
+	    }
+	}
+    }
+
+    # Initialize the string mappings (none known), and the result
+    # accumulator.
+    set data($token,strings) {}
+    set data($token,result)  {}
+
+    if {!$state(stream)} {
+	ParseRecords $token 1
+	if {$state(sax)} {
+	    set result $token
+	} else {
+	    set result $data($token,result)
+	    destroy $token
+	}
+	return $result
+    }
+
+    # Assert: Processing is in background.
+    return $token
+}
+
+# Cleanup a parser, cancelling any callbacks etc.
+
+proc ::bibtex::destroy {token} {
+    variable data
+
+    if {![info exists data($token,stream)]} {
+	return -code error "Illegal bibtex parser \"$token\""
+    }
+    if {$data($token,stream)} {
+	fileevent $data($token,-channel) readable {}
+    }
+
+    array unset data $token,*
+    return
+}
+
+
+proc ::bibtex::wait {token} {
+    variable data
+
+    if {![info exists data($token,stream)]} {
+	return -code error "Illegal bibtex parser \"$token\""
+    }
+    vwait ::bibtex::data($token,done)
+    return
+}
+
+# bibtex::addStrings --
+#
+#	Add strings to the map for a particular parser. All strings are
+#	expanded at parse time.
+
+proc ::bibtex::addStrings {token strings} {
+    variable data
+    eval [linsert $strings 0 lappend data($token,strings)]
+    return
+}
+
+# ### ### ### ######### ######### #########
+## Implementation: Private utility routines
+
+proc ::bibtex::AddRecord {token type key recdata} {
+    variable data
+    lappend  data($token,result) [list $type $key $recdata]
+    return
+}
+
+proc ::bibtex::GetOptions {argv statevar} {
+    upvar 1 $statevar state
+
+    # Basic processing of the argument list
+    # and the options found therein.
+
+    set opts [lrange [::cmdline::GetOptionDefaults {
+	{command.arg              {}}
+	{channel.arg              {}}
+	{recordcommand.arg        {}}
+	{preamblecommand.arg      {}}
+	{stringcommand.arg        {}}
+	{commentcommand.arg       {}}
+	{progresscommand.arg      {}}
+	{casesensitivestrings.arg {}}
+    } result] 2 end] ;# Remove ? and help.
+
+    set argc [llength $argv]
+    while {[set err [::cmdline::getopt argv $opts opt arg]]} {
+	if {$err < 0} {
+	    set olist ""
+	    foreach o [lsort $opts] {
+		if {[string match *.arg $o]} {
+		    set o [string range $o 0 end-4]
+		}
+		lappend olist -$o
+	    }
+	    return -code error "bad option \"$opt\",\
+		    should be one of\
+		    [linsert [join $olist ", "] end-1 or]"
+	}
+	set state(-$opt) $arg
+    }
+
+    # Check the information gained so far
+    # for inconsistencies and/or missing
+    # pieces.
+
+    set sax [expr {
+	[info exists state(-recordcommand)]   ||
+	[info exists state(-preamblecommand)] ||
+	[info exists state(-stringcommand)]   ||
+	[info exists state(-commentcommand)]  ||
+	[info exists state(-progresscommand)]
+    }] ; # {}
+
+    set bg [info exists state(-command)]
+
+    if {$sax && $bg} {
+	# Sax callbacks and channel completion callback exclude each
+	# other.
+	return -code error "The options -command and -TYPEcommand exclude each other"
+    }
+
+    set stream [info exists state(-channel)]
+
+    if {$stream} {
+	# Channel is present, a text is not allowed.
+	if {[llength $argv]} {
+	    return -code error "Option -channel and text exclude each other"
+	}
+
+	# The channel has to exist as well.
+	if {[lsearch -exact [file channels] $state(-channel)] < 0} {
+	    return -code error "Illegal channel handle \"$state(-channel)\""
+	}
+    } else {
+	# Channel is not present, we have to have a text, and only
+	# exactly one. And a general -command callback is not allowed.
+
+	if {![llength $argv]} {
+	    return -code error "Neither -channel nor text specified"
+	} elseif {[llength $argv] > 1} {
+	    return -code error "wrong # args: [lindex [info level 1] 0] ?options? ?bibtex?"
+	}
+
+	# Channel completion callback is not allowed if we are not
+	# reading from a channel.
+
+	if {$bg} {
+	    return -code error "Option -command and text exclude each other"
+	}
+
+	set state(buffer) [lindex $argv 0]
+    }
+
+    set state(stream) $stream
+    set state(sax)    $sax
+    set state(bg)     [expr {$sax || $bg}]
+
+    if {![info exists state(-stringcommand)]} {
+	set state(-stringcommand) [list ::bibtex::addStrings]
+    }
+    if {![info exists state(-recordcommand)] && (!$sax)} {
+	set state(-recordcommand) [list ::bibtex::AddRecord]
+    }
+    if {[info exists state(-casesensitivestrings)] &&
+	$state(-casesensitivestrings)
+    } {
+	set state(casesensitivestrings) 1
+    } else {
+	set state(casesensitivestrings) 0
+    }
+    return
+}
+
+proc ::bibtex::Callback {token type args} {
+    variable data
+
+    #puts stdout "Callback ($token $type ($args))"
+
+    if {[info exists data($token,-${type}command)]} {
+	eval $data($token,-${type}command) [linsert $args 0 $token]
+    }
+    return
+}
+
+proc ::bibtex::ReadChan {token} {
+    variable data
+
+    # Read the waiting characters into our buffer and process
+    # them. The records are saved either through a user supplied
+    # record callback, or the standard callback for our non-sax
+    # processing.
+
+    set    chan $data($token,-channel)
+    append data($token,buffer) [read $chan]
+
+    if {[eof $chan]} {
+	# Final processing. In non-SAX mode we have to deliver the
+	# completed result before destroying the parser.
+
+	ParseRecords $token 1
+	set data($token,done) 1
+	if {!$data($token,sax)} {
+	    Callback $token {} $data($token,result)
+	}
+	return
+    }
+
+    # Processing of partial data.
+
+    ParseRecords $token 0
+    return
+}
+
+proc ::bibtex::Tidy {str} {
+    return [string tolower [string trim $str]]
+}
+
+proc ::bibtex::ParseRecords {token eof} {
+    # A rough BibTeX grammar (case-insensitive):
+    #
+    # Database      ::= (Junk '@' Entry)*
+    # Junk          ::= .*?
+    # Entry         ::= Record
+    #               |   Comment
+    #               |   String
+    #               |   Preamble
+    # Comment       ::= "comment" [^\n]* \n         -- ignored
+    # String        ::= "string" '{' Field* '}'
+    # Preamble      ::= "preamble" '{' .* '}'       -- (balanced)
+    # Record        ::= Type '{' Key ',' Field* '}'
+    #               |   Type '(' Key ',' Field* ')' -- not handled
+    # Type          ::= Name
+    # Key           ::= Name
+    # Field         ::= Name '=' Value
+    # Name          ::= [^\s\"#%'(){}]*
+    # Value         ::= [0-9]+
+    #               |   '"' ([^'"']|\\'"')* '"'
+    #               |   '{' .* '}'                  -- (balanced)
+
+    # " - Fixup emacs hilit confusion from the grammar above.
+    variable data
+    set bibtex $data($token,buffer)
+
+    # Split at each @ character which is at the beginning of a line,
+    # modulo whitespace. This is a heuristic to distinguish the @'s
+    # starting a new record from the @'s occuring inside a record, as
+    # part of email addresses. Empty pices at beginning or end are
+    # stripped before the split.
+
+    regsub -line -all {^[\n\r\f\t ]*@} $bibtex \000 bibtex
+    set db [split [string trim $bibtex \000] \000]
+
+    if {$eof} {
+	set total [llength $db]
+	set step  [expr {double($total) / 100.0}]
+	set istep [expr {$step > 1 ? int($step) : 1}]
+	set count 0
+    } else {
+	if {[llength $db] < 2} {
+	    # Nothing to process, or data which ay be incomplete.
+	    return
+	}
+
+	set data($token,buffer) [lindex $db end]
+	set db                  [lrange $db 0 end-1]
+
+	# Fake progress meter.
+	set count -1
+    }
+
+    foreach block $db {
+	if {$count < 0} {
+	    Callback $token progress -1
+	} elseif {([incr count] % $istep) == 0} {
+	    Callback $token progress [expr {int($count / $step)}]
+	}
+	if {[regexp -nocase {\s*comment([^\n])*\n(.*)} $block \
+		-> cmnt rest]} {
+	    # Are @comments blocks, or just 1 line?
+	    # Does anyone care?
+	    Callback $token comment $cmnt
+
+	} elseif {[regexp -nocase {^\s*string[^\{]*\{(.*)\}[^\}]*} \
+		$block -> rest]} {
+	    # string macro defs
+	    if {$data($token,casesensitivestrings)} {
+		Callback $token string [ParseString $rest]
+	    } else {
+		Callback $token string [ParseBlock $rest]
+	    }
+	} elseif {[regexp -nocase {\s*preamble[^\{]*\{(.*)\}[^\}]*} \
+		$block -> rest]} {
+	    Callback $token preamble $rest
+
+	} elseif {[regexp {([^\{]+)\{([^,]*),(.*)\}[^\}]*} \
+		$block -> type key rest]} {
+	    # Do any @string mappings
+	    if {$data($token,casesensitivestrings)} {
+		# puts $data($token,strings)
+		set rest [string map $data($token,strings) $rest]
+	    } else {
+		set rest [string map -nocase $data($token,strings) $rest]
+	    }
+	    Callback $token record [Tidy $type] [string trim $key] \
+		    [ParseBlock $rest]
+	} else {
+	    ## FUTURE: Use a logger.
+	    puts stderr "Skipping: $block"
+	}
+    }
+}
+
+proc ::bibtex::ParseString {block} {
+    regexp {(\S+)[^=]*=(.*)} $block -> key rest
+    return [list $key $rest]
+}
+
+proc ::bibtex::ParseBlock {block} {
+    set ret   [list]
+    set index 0
+    while {
+	[regexp -start $index -indices -- \
+	     {(\S+)\s*=(.*)} $block -> key rest]
+    } {
+	foreach {ks ke} $key break
+	set k [Tidy [string range $block $ks $ke]]
+	foreach {rs re} $rest break
+	foreach {v index} \
+		[ParseBibString $rs [string range $block $rs $re]] \
+		break
+	lappend ret $k $v
+    }
+    return $ret
+}
+
+proc ::bibtex::ParseBibString {index str} {
+    set count 0
+    set retstr ""
+    set escape 0
+    set string 0
+    foreach char [split $str ""] {
+	incr index
+	if {$escape} {
+	    set escape 0
+	} else {
+	    if {$char eq "\{"} {
+		incr count
+		continue
+	    } elseif {$char eq "\}"} {
+		incr count -1
+		if {$count < 0} {incr index -1; break}
+		continue
+	    } elseif {$char eq ","} {
+		if {$count == 0} break
+	    } elseif {$char eq "\\"} {
+		set escape 1
+		continue
+	    } elseif {$char eq "\""} {
+	        # Handling the case where str is surrounded by
+	        # quotation marks instead of braces (as some journals
+	        # may, perhaps erroneously, print some field. e.g.:
+	        # https://www.epj.org/)
+	        if {$count == 0} {
+	            incr count
+	        } elseif {$count == 1} {
+ 	            incr count -1
+ 	        }
+		continue
+	    }
+	    # else: Nothing
+	}
+	append retstr $char
+    }
+    regsub -all {\s+} $retstr { } retstr
+    return [list [string trim $retstr] $index]
+}
+
+# ### ### ### ######### ######### #########
+## Internal. Package configuration and state.
+
+namespace eval bibtex {
+    # Counter for the generation of parser tokens.
+    variable id 0
+
+    # State of all parsers. Keys for each parser are prefixed with the
+    # parser token.
+    variable  data
+    array set data {}
+
+    # Keys and their meaning (listed without token prefix)
+    ##
+    # buffer
+    # eof
+    # channel    <-\/- Difference ?
+    # strings      |
+    # -async       |
+    # -blocksize   |
+    # -channel   <-/
+    # -recordcommand   -- callback for each record
+    # -preamblecommand -- callback for @preamble blocks
+    # -stringcommand   -- callback for @string macros
+    # -commentcommand  -- callback for @comment blocks
+    # -progresscommand -- callback to indicate progress of parse
+    ##
+}
+
+# ### ### ### ######### ######### #########
+## Ready to go
+package provide bibtex 0.8
+# EOF

src/vendorlib_tcl9/tcllib2.0/bibtex/pkgIndex.tcl

@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {return}
+package ifneeded bibtex 0.8 [list source [file join $dir bibtex.tcl]]

src/vendorlib_tcl9/tcllib2.0/blowfish/blowfish.tcl

@@ -0,0 +1,755 @@
+# blowfish.tcl - 
+#
+#   Pure-Tcl implementation of the Blowfish algorithm.
+#
+#   See http://www.schneier.com/blowfish.html for information about the
+#   Blowfish algorithm.
+#
+#   The implementation is derived from Paul Kocher's implementation,
+#   available at http://www.schneier.com/blowfish-download.html
+#
+# Copyright (C) 2004 Frank Pilhofer
+# Copyright (C) 2004 Pat Thoyts <patthoyts@users.sourceforge.net>
+#
+# -------------------------------------------------------------------------
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# -------------------------------------------------------------------------
+#
+
+package require Tcl 8.5 9
+
+namespace eval blowfish {
+    variable uid
+    if {![info exists uid]} { set uid 0 }
+
+    variable  accel
+    array set accel {trf 0}
+
+    namespace export blowfish
+
+    variable ORIG_P {
+        0x243F6A88 0x85A308D3 0x13198A2E 0x03707344
+        0xA4093822 0x299F31D0 0x082EFA98 0xEC4E6C89
+        0x452821E6 0x38D01377 0xBE5466CF 0x34E90C6C
+        0xC0AC29B7 0xC97C50DD 0x3F84D5B5 0xB5470917
+        0x9216D5D9 0x8979FB1B
+    }
+
+    variable ORIG_S {
+        0xD1310BA6 0x98DFB5AC 0x2FFD72DB 0xD01ADFB7
+        0xB8E1AFED 0x6A267E96 0xBA7C9045 0xF12C7F99
+        0x24A19947 0xB3916CF7 0x0801F2E2 0x858EFC16
+        0x636920D8 0x71574E69 0xA458FEA3 0xF4933D7E
+        0x0D95748F 0x728EB658 0x718BCD58 0x82154AEE
+        0x7B54A41D 0xC25A59B5 0x9C30D539 0x2AF26013
+        0xC5D1B023 0x286085F0 0xCA417918 0xB8DB38EF
+        0x8E79DCB0 0x603A180E 0x6C9E0E8B 0xB01E8A3E
+        0xD71577C1 0xBD314B27 0x78AF2FDA 0x55605C60
+        0xE65525F3 0xAA55AB94 0x57489862 0x63E81440
+        0x55CA396A 0x2AAB10B6 0xB4CC5C34 0x1141E8CE
+        0xA15486AF 0x7C72E993 0xB3EE1411 0x636FBC2A
+        0x2BA9C55D 0x741831F6 0xCE5C3E16 0x9B87931E
+        0xAFD6BA33 0x6C24CF5C 0x7A325381 0x28958677
+        0x3B8F4898 0x6B4BB9AF 0xC4BFE81B 0x66282193
+        0x61D809CC 0xFB21A991 0x487CAC60 0x5DEC8032
+        0xEF845D5D 0xE98575B1 0xDC262302 0xEB651B88
+        0x23893E81 0xD396ACC5 0x0F6D6FF3 0x83F44239
+        0x2E0B4482 0xA4842004 0x69C8F04A 0x9E1F9B5E
+        0x21C66842 0xF6E96C9A 0x670C9C61 0xABD388F0
+        0x6A51A0D2 0xD8542F68 0x960FA728 0xAB5133A3
+        0x6EEF0B6C 0x137A3BE4 0xBA3BF050 0x7EFB2A98
+        0xA1F1651D 0x39AF0176 0x66CA593E 0x82430E88
+        0x8CEE8619 0x456F9FB4 0x7D84A5C3 0x3B8B5EBE
+        0xE06F75D8 0x85C12073 0x401A449F 0x56C16AA6
+        0x4ED3AA62 0x363F7706 0x1BFEDF72 0x429B023D
+        0x37D0D724 0xD00A1248 0xDB0FEAD3 0x49F1C09B
+        0x075372C9 0x80991B7B 0x25D479D8 0xF6E8DEF7
+        0xE3FE501A 0xB6794C3B 0x976CE0BD 0x04C006BA
+        0xC1A94FB6 0x409F60C4 0x5E5C9EC2 0x196A2463
+        0x68FB6FAF 0x3E6C53B5 0x1339B2EB 0x3B52EC6F
+        0x6DFC511F 0x9B30952C 0xCC814544 0xAF5EBD09
+        0xBEE3D004 0xDE334AFD 0x660F2807 0x192E4BB3
+        0xC0CBA857 0x45C8740F 0xD20B5F39 0xB9D3FBDB
+        0x5579C0BD 0x1A60320A 0xD6A100C6 0x402C7279
+        0x679F25FE 0xFB1FA3CC 0x8EA5E9F8 0xDB3222F8
+        0x3C7516DF 0xFD616B15 0x2F501EC8 0xAD0552AB
+        0x323DB5FA 0xFD238760 0x53317B48 0x3E00DF82
+        0x9E5C57BB 0xCA6F8CA0 0x1A87562E 0xDF1769DB
+        0xD542A8F6 0x287EFFC3 0xAC6732C6 0x8C4F5573
+        0x695B27B0 0xBBCA58C8 0xE1FFA35D 0xB8F011A0
+        0x10FA3D98 0xFD2183B8 0x4AFCB56C 0x2DD1D35B
+        0x9A53E479 0xB6F84565 0xD28E49BC 0x4BFB9790
+        0xE1DDF2DA 0xA4CB7E33 0x62FB1341 0xCEE4C6E8
+        0xEF20CADA 0x36774C01 0xD07E9EFE 0x2BF11FB4
+        0x95DBDA4D 0xAE909198 0xEAAD8E71 0x6B93D5A0
+        0xD08ED1D0 0xAFC725E0 0x8E3C5B2F 0x8E7594B7
+        0x8FF6E2FB 0xF2122B64 0x8888B812 0x900DF01C
+        0x4FAD5EA0 0x688FC31C 0xD1CFF191 0xB3A8C1AD
+        0x2F2F2218 0xBE0E1777 0xEA752DFE 0x8B021FA1
+        0xE5A0CC0F 0xB56F74E8 0x18ACF3D6 0xCE89E299
+        0xB4A84FE0 0xFD13E0B7 0x7CC43B81 0xD2ADA8D9
+        0x165FA266 0x80957705 0x93CC7314 0x211A1477
+        0xE6AD2065 0x77B5FA86 0xC75442F5 0xFB9D35CF
+        0xEBCDAF0C 0x7B3E89A0 0xD6411BD3 0xAE1E7E49
+        0x00250E2D 0x2071B35E 0x226800BB 0x57B8E0AF
+        0x2464369B 0xF009B91E 0x5563911D 0x59DFA6AA
+        0x78C14389 0xD95A537F 0x207D5BA2 0x02E5B9C5
+        0x83260376 0x6295CFA9 0x11C81968 0x4E734A41
+        0xB3472DCA 0x7B14A94A 0x1B510052 0x9A532915
+        0xD60F573F 0xBC9BC6E4 0x2B60A476 0x81E67400
+        0x08BA6FB5 0x571BE91F 0xF296EC6B 0x2A0DD915
+        0xB6636521 0xE7B9F9B6 0xFF34052E 0xC5855664
+        0x53B02D5D 0xA99F8FA1 0x08BA4799 0x6E85076A
+        0x4B7A70E9 0xB5B32944 0xDB75092E 0xC4192623
+        0xAD6EA6B0 0x49A7DF7D 0x9CEE60B8 0x8FEDB266
+        0xECAA8C71 0x699A17FF 0x5664526C 0xC2B19EE1
+        0x193602A5 0x75094C29 0xA0591340 0xE4183A3E
+        0x3F54989A 0x5B429D65 0x6B8FE4D6 0x99F73FD6
+        0xA1D29C07 0xEFE830F5 0x4D2D38E6 0xF0255DC1
+        0x4CDD2086 0x8470EB26 0x6382E9C6 0x021ECC5E
+        0x09686B3F 0x3EBAEFC9 0x3C971814 0x6B6A70A1
+        0x687F3584 0x52A0E286 0xB79C5305 0xAA500737
+        0x3E07841C 0x7FDEAE5C 0x8E7D44EC 0x5716F2B8
+        0xB03ADA37 0xF0500C0D 0xF01C1F04 0x0200B3FF
+        0xAE0CF51A 0x3CB574B2 0x25837A58 0xDC0921BD
+        0xD19113F9 0x7CA92FF6 0x94324773 0x22F54701
+        0x3AE5E581 0x37C2DADC 0xC8B57634 0x9AF3DDA7
+        0xA9446146 0x0FD0030E 0xECC8C73E 0xA4751E41
+        0xE238CD99 0x3BEA0E2F 0x3280BBA1 0x183EB331
+        0x4E548B38 0x4F6DB908 0x6F420D03 0xF60A04BF
+        0x2CB81290 0x24977C79 0x5679B072 0xBCAF89AF
+        0xDE9A771F 0xD9930810 0xB38BAE12 0xDCCF3F2E
+        0x5512721F 0x2E6B7124 0x501ADDE6 0x9F84CD87
+        0x7A584718 0x7408DA17 0xBC9F9ABC 0xE94B7D8C
+        0xEC7AEC3A 0xDB851DFA 0x63094366 0xC464C3D2
+        0xEF1C1847 0x3215D908 0xDD433B37 0x24C2BA16
+        0x12A14D43 0x2A65C451 0x50940002 0x133AE4DD
+        0x71DFF89E 0x10314E55 0x81AC77D6 0x5F11199B
+        0x043556F1 0xD7A3C76B 0x3C11183B 0x5924A509
+        0xF28FE6ED 0x97F1FBFA 0x9EBABF2C 0x1E153C6E
+        0x86E34570 0xEAE96FB1 0x860E5E0A 0x5A3E2AB3
+        0x771FE71C 0x4E3D06FA 0x2965DCB9 0x99E71D0F
+        0x803E89D6 0x5266C825 0x2E4CC978 0x9C10B36A
+        0xC6150EBA 0x94E2EA78 0xA5FC3C53 0x1E0A2DF4
+        0xF2F74EA7 0x361D2B3D 0x1939260F 0x19C27960
+        0x5223A708 0xF71312B6 0xEBADFE6E 0xEAC31F66
+        0xE3BC4595 0xA67BC883 0xB17F37D1 0x018CFF28
+        0xC332DDEF 0xBE6C5AA5 0x65582185 0x68AB9802
+        0xEECEA50F 0xDB2F953B 0x2AEF7DAD 0x5B6E2F84
+        0x1521B628 0x29076170 0xECDD4775 0x619F1510
+        0x13CCA830 0xEB61BD96 0x0334FE1E 0xAA0363CF
+        0xB5735C90 0x4C70A239 0xD59E9E0B 0xCBAADE14
+        0xEECC86BC 0x60622CA7 0x9CAB5CAB 0xB2F3846E
+        0x648B1EAF 0x19BDF0CA 0xA02369B9 0x655ABB50
+        0x40685A32 0x3C2AB4B3 0x319EE9D5 0xC021B8F7
+        0x9B540B19 0x875FA099 0x95F7997E 0x623D7DA8
+        0xF837889A 0x97E32D77 0x11ED935F 0x16681281
+        0x0E358829 0xC7E61FD6 0x96DEDFA1 0x7858BA99
+        0x57F584A5 0x1B227263 0x9B83C3FF 0x1AC24696
+        0xCDB30AEB 0x532E3054 0x8FD948E4 0x6DBC3128
+        0x58EBF2EF 0x34C6FFEA 0xFE28ED61 0xEE7C3C73
+        0x5D4A14D9 0xE864B7E3 0x42105D14 0x203E13E0
+        0x45EEE2B6 0xA3AAABEA 0xDB6C4F15 0xFACB4FD0
+        0xC742F442 0xEF6ABBB5 0x654F3B1D 0x41CD2105
+        0xD81E799E 0x86854DC7 0xE44B476A 0x3D816250
+        0xCF62A1F2 0x5B8D2646 0xFC8883A0 0xC1C7B6A3
+        0x7F1524C3 0x69CB7492 0x47848A0B 0x5692B285
+        0x095BBF00 0xAD19489D 0x1462B174 0x23820E00
+        0x58428D2A 0x0C55F5EA 0x1DADF43E 0x233F7061
+        0x3372F092 0x8D937E41 0xD65FECF1 0x6C223BDB
+        0x7CDE3759 0xCBEE7460 0x4085F2A7 0xCE77326E
+        0xA6078084 0x19F8509E 0xE8EFD855 0x61D99735
+        0xA969A7AA 0xC50C06C2 0x5A04ABFC 0x800BCADC
+        0x9E447A2E 0xC3453484 0xFDD56705 0x0E1E9EC9
+        0xDB73DBD3 0x105588CD 0x675FDA79 0xE3674340
+        0xC5C43465 0x713E38D8 0x3D28F89E 0xF16DFF20
+        0x153E21E7 0x8FB03D4A 0xE6E39F2B 0xDB83ADF7
+        0xE93D5A68 0x948140F7 0xF64C261C 0x94692934
+        0x411520F7 0x7602D4F7 0xBCF46B2E 0xD4A20068
+        0xD4082471 0x3320F46A 0x43B7D4B7 0x500061AF
+        0x1E39F62E 0x97244546 0x14214F74 0xBF8B8840
+        0x4D95FC1D 0x96B591AF 0x70F4DDD3 0x66A02F45
+        0xBFBC09EC 0x03BD9785 0x7FAC6DD0 0x31CB8504
+        0x96EB27B3 0x55FD3941 0xDA2547E6 0xABCA0A9A
+        0x28507825 0x530429F4 0x0A2C86DA 0xE9B66DFB
+        0x68DC1462 0xD7486900 0x680EC0A4 0x27A18DEE
+        0x4F3FFEA2 0xE887AD8C 0xB58CE006 0x7AF4D6B6
+        0xAACE1E7C 0xD3375FEC 0xCE78A399 0x406B2A42
+        0x20FE9E35 0xD9F385B9 0xEE39D7AB 0x3B124E8B
+        0x1DC9FAF7 0x4B6D1856 0x26A36631 0xEAE397B2
+        0x3A6EFA74 0xDD5B4332 0x6841E7F7 0xCA7820FB
+        0xFB0AF54E 0xD8FEB397 0x454056AC 0xBA489527
+        0x55533A3A 0x20838D87 0xFE6BA9B7 0xD096954B
+        0x55A867BC 0xA1159A58 0xCCA92963 0x99E1DB33
+        0xA62A4A56 0x3F3125F9 0x5EF47E1C 0x9029317C
+        0xFDF8E802 0x04272F70 0x80BB155C 0x05282CE3
+        0x95C11548 0xE4C66D22 0x48C1133F 0xC70F86DC
+        0x07F9C9EE 0x41041F0F 0x404779A4 0x5D886E17
+        0x325F51EB 0xD59BC0D1 0xF2BCC18F 0x41113564
+        0x257B7834 0x602A9C60 0xDFF8E8A3 0x1F636C1B
+        0x0E12B4C2 0x02E1329E 0xAF664FD1 0xCAD18115
+        0x6B2395E0 0x333E92E1 0x3B240B62 0xEEBEB922
+        0x85B2A20E 0xE6BA0D99 0xDE720C8C 0x2DA2F728
+        0xD0127845 0x95B794FD 0x647D0862 0xE7CCF5F0
+        0x5449A36F 0x877D48FA 0xC39DFD27 0xF33E8D1E
+        0x0A476341 0x992EFF74 0x3A6F6EAB 0xF4F8FD37
+        0xA812DC60 0xA1EBDDF8 0x991BE14C 0xDB6E6B0D
+        0xC67B5510 0x6D672C37 0x2765D43B 0xDCD0E804
+        0xF1290DC7 0xCC00FFA3 0xB5390F92 0x690FED0B
+        0x667B9FFB 0xCEDB7D9C 0xA091CF0B 0xD9155EA3
+        0xBB132F88 0x515BAD24 0x7B9479BF 0x763BD6EB
+        0x37392EB3 0xCC115979 0x8026E297 0xF42E312D
+        0x6842ADA7 0xC66A2B3B 0x12754CCC 0x782EF11C
+        0x6A124237 0xB79251E7 0x06A1BBE6 0x4BFB6350
+        0x1A6B1018 0x11CAEDFA 0x3D25BDD8 0xE2E1C3C9
+        0x44421659 0x0A121386 0xD90CEC6E 0xD5ABEA2A
+        0x64AF674E 0xDA86A85F 0xBEBFE988 0x64E4C3FE
+        0x9DBC8057 0xF0F7C086 0x60787BF8 0x6003604D
+        0xD1FD8346 0xF6381FB0 0x7745AE04 0xD736FCCC
+        0x83426B33 0xF01EAB71 0xB0804187 0x3C005E5F
+        0x77A057BE 0xBDE8AE24 0x55464299 0xBF582E61
+        0x4E58F48F 0xF2DDFDA2 0xF474EF38 0x8789BDC2
+        0x5366F9C3 0xC8B38E74 0xB475F255 0x46FCD9B9
+        0x7AEB2661 0x8B1DDF84 0x846A0E79 0x915F95E2
+        0x466E598E 0x20B45770 0x8CD55591 0xC902DE4C
+        0xB90BACE1 0xBB8205D0 0x11A86248 0x7574A99E
+        0xB77F19B6 0xE0A9DC09 0x662D09A1 0xC4324633
+        0xE85A1F02 0x09F0BE8C 0x4A99A025 0x1D6EFE10
+        0x1AB93D1D 0x0BA5A4DF 0xA186F20F 0x2868F169
+        0xDCB7DA83 0x573906FE 0xA1E2CE9B 0x4FCD7F52
+        0x50115E01 0xA70683FA 0xA002B5C4 0x0DE6D027
+        0x9AF88C27 0x773F8641 0xC3604C06 0x61A806B5
+        0xF0177A28 0xC0F586E0 0x006058AA 0x30DC7D62
+        0x11E69ED7 0x2338EA63 0x53C2DD94 0xC2C21634
+        0xBBCBEE56 0x90BCB6DE 0xEBFC7DA1 0xCE591D76
+        0x6F05E409 0x4B7C0188 0x39720A3D 0x7C927C24
+        0x86E3725F 0x724D9DB9 0x1AC15BB4 0xD39EB8FC
+        0xED545578 0x08FCA5B5 0xD83D7CD3 0x4DAD0FC4
+        0x1E50EF5E 0xB161E6F8 0xA28514D9 0x6C51133C
+        0x6FD5C7E7 0x56E14EC4 0x362ABFCE 0xDDC6C837
+        0xD79A3234 0x92638212 0x670EFA8E 0x406000E0
+        0x3A39CE37 0xD3FAF5CF 0xABC27737 0x5AC52D1B
+        0x5CB0679E 0x4FA33742 0xD3822740 0x99BC9BBE
+        0xD5118E9D 0xBF0F7315 0xD62D1C7E 0xC700C47B
+        0xB78C1B6B 0x21A19045 0xB26EB1BE 0x6A366EB4
+        0x5748AB2F 0xBC946E79 0xC6A376D2 0x6549C2C8
+        0x530FF8EE 0x468DDE7D 0xD5730A1D 0x4CD04DC6
+        0x2939BBDB 0xA9BA4650 0xAC9526E8 0xBE5EE304
+        0xA1FAD5F0 0x6A2D519A 0x63EF8CE2 0x9A86EE22
+        0xC089C2B8 0x43242EF6 0xA51E03AA 0x9CF2D0A4
+        0x83C061BA 0x9BE96A4D 0x8FE51550 0xBA645BD6
+        0x2826A2F9 0xA73A3AE1 0x4BA99586 0xEF5562E9
+        0xC72FEFD3 0xF752F7DA 0x3F046F69 0x77FA0A59
+        0x80E4A915 0x87B08601 0x9B09E6AD 0x3B3EE593
+        0xE990FD5A 0x9E34D797 0x2CF0B7D9 0x022B8B51
+        0x96D5AC3A 0x017DA67D 0xD1CF3ED6 0x7C7D2D28
+        0x1F9F25CF 0xADF2B89B 0x5AD6B472 0x5A88F54C
+        0xE029AC71 0xE019A5E6 0x47B0ACFD 0xED93FA9B
+        0xE8D3C48D 0x283B57CC 0xF8D56629 0x79132E28
+        0x785F0191 0xED756055 0xF7960E44 0xE3D35E8C
+        0x15056DD4 0x88F46DBA 0x03A16125 0x0564F0BD
+        0xC3EB9E15 0x3C9057A2 0x97271AEC 0xA93A072A
+        0x1B3F6D9B 0x1E6321F5 0xF59C66FB 0x26DCF319
+        0x7533D928 0xB155FDF5 0x03563482 0x8ABA3CBB
+        0x28517711 0xC20AD9F8 0xABCC5167 0xCCAD925F
+        0x4DE81751 0x3830DC8E 0x379D5862 0x9320F991
+        0xEA7A90C2 0xFB3E7BCE 0x5121CE64 0x774FBE32
+        0xA8B6E37E 0xC3293D46 0x48DE5369 0x6413E680
+        0xA2AE0810 0xDD6DB224 0x69852DFD 0x09072166
+        0xB39A460A 0x6445C0DD 0x586CDECF 0x1C20C8AE
+        0x5BBEF7DD 0x1B588D40 0xCCD2017F 0x6BB4E3BB
+        0xDDA26A7E 0x3A59FF45 0x3E350A44 0xBCB4CDD5
+        0x72EACEA8 0xFA6484BB 0x8D6612AE 0xBF3C6F47
+        0xD29BE463 0x542F5D9E 0xAEC2771B 0xF64E6370
+        0x740E0D8D 0xE75B1357 0xF8721671 0xAF537D5D
+        0x4040CB08 0x4EB4E2CC 0x34D2466A 0x0115AF84
+        0xE1B00428 0x95983A1D 0x06B89FB4 0xCE6EA048
+        0x6F3F3B82 0x3520AB82 0x011A1D4B 0x277227F8
+        0x611560B1 0xE7933FDC 0xBB3A792B 0x344525BD
+        0xA08839E1 0x51CE794B 0x2F32C9B7 0xA01FBAC9
+        0xE01CC87E 0xBCC7D1F6 0xCF0111C3 0xA1E8AAC7
+        0x1A908749 0xD44FBD9A 0xD0DADECB 0xD50ADA38
+        0x0339C32A 0xC6913667 0x8DF9317C 0xE0B12B4F
+        0xF79E59B7 0x43F5BB3A 0xF2D519FF 0x27D9459C
+        0xBF97222C 0x15E6FC2A 0x0F91FC71 0x9B941525
+        0xFAE59361 0xCEB69CEB 0xC2A86459 0x12BAA8D1
+        0xB6C1075E 0xE3056A0C 0x10D25065 0xCB03A442
+        0xE0EC6E0E 0x1698DB3B 0x4C98A0BE 0x3278E964
+        0x9F1F9532 0xE0D392DF 0xD3A0342B 0x8971F21E
+        0x1B0A7441 0x4BA3348C 0xC5BE7120 0xC37632D8
+        0xDF359F8D 0x9B992F2E 0xE60B6F47 0x0FE3F11D
+        0xE54CDA54 0x1EDAD891 0xCE6279CF 0xCD3E7E6F
+        0x1618B166 0xFD2C1D05 0x848FD2C5 0xF6FB2299
+        0xF523F357 0xA6327623 0x93A83531 0x56CCCD02
+        0xACF08162 0x5A75EBB5 0x6E163697 0x88D273CC
+        0xDE966292 0x81B949D0 0x4C50901B 0x71C65614
+        0xE6C6C7BD 0x327A140A 0x45E1D006 0xC3F27B9A
+        0xC9AA53FD 0x62A80F00 0xBB25BFE2 0x35BDD2F6
+        0x71126905 0xB2040222 0xB6CBCF7C 0xCD769C2B
+        0x53113EC0 0x1640E3D3 0x38ABBD60 0x2547ADF0
+        0xBA38209C 0xF746CE76 0x77AFA1C5 0x20756060
+        0x85CBFE4E 0x8AE88DD8 0x7AAAF9B0 0x4CF9AA7E
+        0x1948C25C 0x02FB8A8C 0x01C36AE4 0xD6EBE1F9
+        0x90D4F869 0xA65CDEA0 0x3F09252D 0xC208E69F
+        0xB74E6132 0xCE77E25B 0x578FDFE3 0x3AC372E6
+    }
+}
+
+proc ::blowfish::intEncrypt {P S xl xr} {
+    for {set i 0} {$i < 16} {incr i} {
+        set xl [expr {$xl ^ [lindex $P $i]}]
+
+        set S0a [lindex $S [expr { ($xl >> 24) & 0xff}]]
+        set S1b [lindex $S [expr {(($xl >> 16) & 0xff) + 256}]]
+        set S2c [lindex $S [expr {(($xl >>  8) & 0xff) + 512}]]
+        set S3d [lindex $S [expr { ($xl        & 0xff) + 768}]]
+        set xr [expr {(((($S0a + $S1b) ^ $S2c) + $S3d) & 0xffffffff) ^ $xr}]
+
+        set temp $xl ; set xl $xr ; set xr $temp
+    }
+
+    set temp $xl ; set xl $xr ; set xr $temp
+    return [list [expr {$xl ^ [lindex $P 17]}] [expr {$xr ^ [lindex $P 16]}]]
+}
+
+proc ::blowfish::intDecrypt {P S xl xr} {
+    for {set i 17} {$i > 1} {incr i -1} {
+        set xl [expr {$xl ^ [lindex $P $i]}]
+
+        set S0a [lindex $S [expr { ($xl >> 24) & 0xff}]]
+        set S1b [lindex $S [expr {(($xl >> 16) & 0xff) + 256}]]
+        set S2c [lindex $S [expr {(($xl >>  8) & 0xff) + 512}]]
+        set S3d [lindex $S [expr { ($xl        & 0xff) + 768}]]
+        set xr [expr {(((($S0a + $S1b) ^ $S2c) + $S3d) & 0xffffffff) ^ $xr}]
+
+        set temp $xl ; set xl $xr ; set xr $temp
+    }
+    
+    set temp $xl ; set xl $xr ; set xr $temp
+    return [list [expr {$xl ^ [lindex $P 0]}] [expr {$xr ^ [lindex $P 1]}]]
+}
+
+proc ::blowfish::Init {mode key iv} {
+    variable ORIG_S
+    variable ORIG_P
+    variable uid
+
+    set S $ORIG_S
+    set P [list]
+    
+    set kl [string length $key]
+    binary scan $key c* kc
+    
+    set j 0
+    for {set i 0} {$i < 18} {incr i} {
+        set data 0
+        for {set k 0} {$k < 4} {incr k} {
+            set data [expr {(($data << 8) | ([lindex $kc $j] & 0xff)) & 0xffffffff}]
+            if {[incr j] >= $kl} {
+                set j 0
+            }
+        }
+        set OPi [lindex $ORIG_P $i]
+        lappend P [expr {$OPi ^ $data}]
+    }
+    
+    set datal 0
+    set datar 0
+    
+    for {set i 0} {$i < 18} {incr i} {
+        set ed [intEncrypt $P $S $datal $datar]
+        set datal [lindex $ed 0]
+        set datar [lindex $ed 1]
+        set P [lreplace $P $i [incr i] $datal $datar]
+    }
+    
+    for {set i 0} {$i < 4} {incr i} {
+        for {set j 0} {$j < 256} {incr j 2} {
+            set ed [intEncrypt $P $S $datal $datar]
+            set datal [lindex $ed 0]
+            set datar [lindex $ed 1]
+            set t [expr {$i * 256 + $j}]
+            set S [lreplace $S $t [incr t] $datal $datar]
+        }
+    }
+
+    set token [namespace current]::[incr uid]
+    variable $token
+    upvar #0 $token state
+    array set state [list P $P S $S M $mode I $iv]
+    return $token
+}
+
+proc ::blowfish::Reset {token iv} {
+    upvar #0 $token state
+    set state(I) $iv
+    return
+}
+
+proc ::blowfish::Final {token} {
+    # PRAGMA: nocheck
+    variable $token
+    unset $token
+}
+
+proc ::blowfish::EncryptBlock {token block} {
+    upvar #0 $token state
+    if {[binary scan $block II xl xr] != 2} {
+        error "block must be 8 bytes"
+    }
+    set xl [expr {$xl & 0xffffffff}]
+    set xr [expr {$xr & 0xffffffff}]
+    set d  [intEncrypt $state(P) $state(S) $xl $xr]
+    return [binary format I2 $d]
+}
+
+proc ::blowfish::Encrypt {Key data} {
+    upvar #0 $Key state
+    set P $state(P)
+    set S $state(S)
+    set cbc_mode [string equal "cbc" $state(M)]
+
+    if {[binary scan $state(I) II s0 s1] != 2} {
+        return -code error "invalid initialization vector: must be 8 bytes"
+    }
+
+    set len [string length $data]
+    if {($len % 8) != 0} {
+        return -code error "invalid block size: blocks must be 8 bytes"
+    }
+
+    set s0 [expr {$s0 & 0xffffffff}]
+    set s1 [expr {$s1 & 0xffffffff}]
+    
+    set result ""
+    for {set i 0} {$i < $len} {incr i 8} {
+        if {[binary scan $data @[set i]II xl xr] != 2} {
+            return -code error "oops"
+        }
+        if {$cbc_mode} {
+            set xl [expr {($xl & 0xffffffff) ^ $s0}]
+            set xr [expr {($xr & 0xffffffff) ^ $s1}]
+        }
+        set d  [intEncrypt $P $S $xl $xr]
+        if {$cbc_mode} {
+            set s0 [lindex $d 0]
+            set s1 [lindex $d 1]
+        }
+        append result [binary format I2 $d]
+    }
+    if {$cbc_mode} {
+        set state(I) [binary format II $s0 $s1]
+    }
+    return $result
+}
+
+proc ::blowfish::DecryptBlock {Key block} {
+    upvar #0 $Key state
+    if {[binary scan $block II xl xr] != 2} {
+        return -code error "invalid block size: block must be 8 bytes"
+    }
+    set xl [expr {$xl & 0xffffffff}]
+    set xr [expr {$xr & 0xffffffff}]
+    set d  [intDecrypt $state(P) $state(S) $xl $xr]
+    return [binary format I2 $d]
+}
+
+proc ::blowfish::Decrypt {token data} {
+    upvar #0 $token state
+    set P $state(P)
+    set S $state(S)
+    set cbc_mode [string equal "cbc" $state(M)]
+
+    if {[binary scan $state(I) II s0 s1] != 2} {
+        return -code error "initialization vector must be 8 bytes"
+    }
+
+    set len [string length $data]
+    if {($len % 8) != 0} {
+        return -code error "block size invalid"
+    }
+
+    set s0 [expr {$s0 & 0xffffffff}]
+    set s1 [expr {$s1 & 0xffffffff}]
+
+    set result ""
+    for {set i 0} {$i < $len} {incr i 8} {
+        if {[binary scan $data @[set i]II xl xr] != 2} {
+            error "oops"
+        }
+        set xl [expr {$xl & 0xffffffff}]
+        set xr [expr {$xr & 0xffffffff}]
+        set d  [intDecrypt $P $S $xl $xr]
+        if {$cbc_mode} {
+            set d0 [lindex $d 0]
+            set d1 [lindex $d 1]
+            set c0 [expr {$d0 ^ $s0}]
+            set c1 [expr {$d1 ^ $s1}]
+            set s0 $xl
+            set s1 $xr
+            append result [binary format II $c0 $c1]
+        } else {
+            append result [binary format I2 $d]
+        }
+    }
+    if {$cbc_mode} {
+        set state(I) [binary format II $s0 $s1]
+    }
+    return $result
+}
+
+
+# -------------------------------------------------------------------------
+# Fileevent handler for chunked file reading.
+#
+proc ::blowfish::Chunk {Key in {out {}} {chunksize 4096} {pad \0}} {
+    upvar #0 $Key state
+    
+    if {[eof $in]} {
+        fileevent $in readable {}
+        set state(reading) 0
+        set data $state(remainder)
+
+        # Only pad at the end of the stream.
+        if {[string length $pad] > 0} {
+            set data [Pad $data 8 $pad]
+        }
+    } else {
+        set data [read $in $chunksize]
+        #puts "Chunk: reading [string len $data] bytes"
+        set data $state(remainder)$data
+
+        # If data is not a multiple of 8, state(remainder) will hold
+        # excess bytes for the next round.
+        set pagedlen         [expr {([string length $data] / 8) * 8}]
+        set state(remainder) [string range $data $pagedlen end]
+        incr pagedlen        -1
+        set data             [string range $data 0 $pagedlen]
+    }
+
+    if {![string length $data]} return
+
+    if {[set code [catch {
+        set cipher [$state(cmd) $Key $data]
+    } msg]]} {
+        fileevent $in readable {}
+        set state(reading) 0
+        set state(err) [list $code $msg]
+        return
+    }
+    
+    if {$out == {}} {
+        append state(output) $cipher
+    } else {
+        puts -nonewline $out $cipher
+    }
+}
+
+# -------------------------------------------------------------------------
+
+# LoadAccelerator --
+#
+#	This package can make use of a number of compiled extensions to
+#	accelerate the digest computation. This procedure manages the
+#	use of these extensions within the package. During normal usage
+#	this should not be called, but the test package manipulates the
+#	list of enabled accelerators.
+#
+proc ::blowfish::LoadAccelerator {name} {
+    variable accel
+    set r 0
+    switch -exact -- $name {
+        trf {
+            if {![catch {package require Trfcrypt}]} {
+                set block [string repeat \0 8]
+                set r [expr {![catch {::blowfish -dir enc -mode ecb -key $block $block} msg]}]
+            }
+        }
+        default {
+            return -code error "invalid accelerator package:\
+                must be one of [join [array names accel] {, }]"
+        }
+    }
+    set accel($name) $r
+}
+
+# -------------------------------------------------------------------------
+
+proc ::blowfish::Hex {data} {
+    binary scan $data H* r
+    return $r
+}
+
+proc ::blowfish::SetOneOf {lst item} {                
+    set ndx [lsearch -glob $lst "${item}*"]
+    if {$ndx == -1} {
+        set err [join $lst ", "]
+        return -code error "invalid mode \"$item\": must be one of $err"
+    }
+    return [lindex $lst $ndx]
+}
+
+proc ::blowfish::CheckSize {what size thing} {
+    if {[string length $thing] != $size} {
+        return -code error "invalid value for $what: must be $size bytes long"
+    }
+    return $thing
+}
+
+proc ::blowfish::CheckPad {char} {
+    if {[string length $char] > 1} {
+        return -code error "invalid value: should be a char or empty string"
+    }
+    return $char
+}
+
+proc ::blowfish::Pad {data blocksize {fill \0}} {
+    set len [string length $data]
+    if {$len == 0} {
+        # do not pad an empty string
+    } elseif {($len % $blocksize) != 0} {
+        set pad [expr {$blocksize - ($len % $blocksize)}]
+        append data [string repeat $fill $pad]
+    }
+    return $data
+}
+
+# Description:
+#  Pop the nth element off a list. Used in options processing.
+#
+proc ::blowfish::Pop {varname {nth 0}} {
+    upvar $varname args
+    set r [lindex $args $nth]
+    set args [lreplace $args $nth $nth]
+    return $r
+}
+
+proc ::blowfish::blowfish {args} {
+    variable accel
+    array set opts {-dir encrypt -mode cbc -key {} -in {} -out {} -hex 0 -pad \0}
+    set opts(-chunksize) 4096
+    set opts(-iv) [string repeat \0 8]
+    set modes {ecb cbc}
+    set dirs  {encrypt decrypt}
+    while {[string match -* [set option [lindex $args 0]]]} {
+        switch -exact -- $option {
+            -mode       { set opts(-mode) [SetOneOf $modes [Pop args 1]] }
+            -dir        { set opts(-dir) [SetOneOf $dirs [Pop args 1]] }
+            -iv         { set opts(-iv)  [CheckSize -iv 8 [Pop args 1]] }
+            -key        { set opts(-key) [Pop args 1] }
+            -in         { set opts(-in) [Pop args 1] }
+            -out        { set opts(-out) [Pop args 1] }
+            -chunksize  { set opts(-chunksize) [Pop args 1] }
+            -hex        { set opts(-hex) 1 }
+            -pad        { set opts(-pad) [CheckPad [Pop args 1]] }
+            --          { Pop args; break }
+            default {
+                if {[string length $opts(-in)] == 0 && [llength $args] == 1} break
+                set err [join [lsort [array names opts]] ", "]
+                return -code error "bad option \"$option\":\
+                    must be one of $err"
+            }
+        }
+        Pop args
+    }
+    
+    if {$opts(-key) == {}} {
+        return -code error "no key provided: the -key option is required"
+    }
+    
+    set r {}
+    if {$opts(-in) == {}} {
+        # Immediate data (plain text is argument).
+        
+        if {[llength $args] != 1} {
+            return -code error "wrong \# args:\
+                should be \"blowfish ?options...? -key keydata plaintext\""
+        }
+
+        set data [lindex $args 0]
+        if {[string length $opts(-pad)] > 0} {
+            set data [Pad [lindex $args 0] 8 $opts(-pad)]
+        }
+        if {$accel(trf)} {
+            set r [::blowfish -dir $opts(-dir) -mode $opts(-mode) \
+                       -key $opts(-key) -iv $opts(-iv) -- $data]
+        } else {
+            set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
+            if {[string equal $opts(-dir) "encrypt"]} {
+                set r [Encrypt $Key $data]
+            } else {
+                set r [Decrypt $Key $data]
+            }
+            Final $Key
+        }
+
+        if {$opts(-out) != {}} {
+            puts -nonewline $opts(-out) $r
+            set r {}
+        }
+        
+    } else {
+        # Channel data (plain text is read from a binary channel).
+        
+        if {[llength $args] != 0} {
+            return -code error "wrong \# args:\
+                should be \"blowfish ?options...? -key keydata -in channel\""
+        }
+        
+        set Key [Init $opts(-mode) $opts(-key) $opts(-iv)]
+        upvar $Key state
+        set state(reading) 1
+        if {[string equal $opts(-dir) "encrypt"]} {
+            set state(cmd) Encrypt
+        } else {
+            set state(cmd) Decrypt
+        }
+        set state(output) ""
+        set state(remainder) ""
+        fileevent $opts(-in) readable \
+            [list [namespace origin Chunk] \
+                 $Key $opts(-in) $opts(-out) $opts(-chunksize) $opts(-pad)]
+        if {[info commands ::tkwait] != {}} {
+            tkwait variable [subst $Key](reading)
+        } else {
+            vwait [subst $Key](reading)
+        }
+
+        if {[info exists state(err)]} {
+            foreach {code msg} $state(err) break
+            return -code $code $msg
+        }
+        
+        if {$opts(-out) == {}} {
+            set r $state(output)
+        }
+        Final $Key
+
+    }
+
+    if {$opts(-hex)} {
+        set r [Hex $r]
+    }
+    return $r
+}
+
+# -------------------------------------------------------------------------
+
+# Try and load a compiled extension to help.
+namespace eval ::blowfish {
+    variable e {}
+    foreach e {trf} {
+        if {[LoadAccelerator $e]} break
+    }
+    unset e
+}
+
+package provide blowfish 1.0.6
+
+# -------------------------------------------------------------------------
+#
+# Local Variables:
+# mode: tcl
+# indent-tabs-mode: nil
+# End:

src/vendorlib_tcl9/tcllib2.0/blowfish/pkgIndex.tcl

@@ -0,0 +1,5 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {
+    # PRAGMA: returnok
+    return
+}
+package ifneeded blowfish 1.0.6 [list source [file join $dir blowfish.tcl]]

src/vendorlib_tcl9/tcllib2.0/cache/async.tcl

@@ -0,0 +1,185 @@
+## -*- tcl -*-
+# ### ### ### ######### ######### #########
+
+# Copyright (c) 2008 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+# Aynchronous in-memory cache. Queries of the cache generate
+# asynchronous requests for data for unknown parts, with asynchronous
+# result return. Data found in the cache may return fully asynchronous
+# as well, or semi-synchronous. The latter meaning that the regular
+# callbacks are used, but invoked directly, and not decoupled through
+# events. The cache can be pre-filled synchronously.
+
+# ### ### ### ######### ######### #########
+## Requisites
+
+package require Tcl 8.5 9 ; #
+package require snit    ; # 
+
+# ### ### ### ######### ######### #########
+##
+
+snit::type cache::async {
+
+    # ### ### ### ######### ######### #########
+    ## Unknown methods and options are forwared to the object actually
+    ## providing the cached data, making the cache a proper facade for
+    ## it.
+
+    delegate method * to myprovider
+    delegate option * to myprovider
+
+    # ### ### ### ######### ######### #########
+    ## API 
+
+    option -full-async-results -default 1 -type snit::boolean
+
+    constructor {provider args} {
+	set myprovider $provider
+	$self configurelist $args
+	return
+    }
+
+    method get {key donecmd} {
+	# Register request
+	lappend mywaiting($key) $donecmd
+
+	# Check if the request can be satisfied from the cache. If yes
+	# then that is done.
+
+	if {[info exists mymiss($key)]} {
+	    $self NotifyUnset 1 $key
+	    return
+	} elseif {[info exists myhit($key)]} {
+	    $self NotifySet 1 $key
+	    return
+	}
+
+	# We have to ask our provider if there is data or
+	# not. however, if a request for this key is already in flight
+	# then we have to do nothing more. Our registration at the
+	# beginning ensures that we will get notified when the
+	# requested information comes back.
+
+	if {[llength $mywaiting($key)] > 1} return
+
+	# This is the first query for this key, ask the provider.
+
+	after idle [linsert $myprovider end get $key $self]
+	return
+    }
+
+    method clear {args} {
+	# Note: This method cannot interfere with async queries caused
+	# by 'get' invokations.  If the data is present, and now
+	# removed, all 'get' invokations before this call were
+	# satisfied from the cache and only invokations coming after
+	# it can trigger async queries of the provider. If the data is
+	# not present the state will not change, and queries in flight
+	# simply refill the cache as they would do anyway without the
+	# 'clear'.
+
+	if {![llength $args]} {
+	    array unset myhit  *
+	    array unset mymiss *
+	} elseif {[llength $args] == 1} {
+	    set key [lindex $args 0]
+	    unset -nocomplain  myhit($key)
+	    unset -nocomplain mymiss($key)
+	} else {
+	    WrongArgs ?key?
+	}
+	return
+    }
+
+    method exists {key} {
+	return [expr {[info exists myhit($key)] || [info exists mymiss($key)]}]
+    }
+
+    method set {key value} {
+	# Add data to the cache, and notify all outstanding queries.
+	# Nothing is done if the key is already known and has the same
+	# value.
+
+	# This is the method invoked by the provider in response to
+	# queries, and also the method to use to prefill the cache
+	# with data.
+
+	if {
+	    [info exists myhit($key)] &&
+	    ($value eq $myhit($key))
+	} return
+
+	set                myhit($key) $value
+	unset -nocomplain mymiss($key)
+	$self NotifySet 0 $key
+	return
+    }
+
+    method unset {key} {
+	# Add hole to the cache, and notify all outstanding queries.
+	# This is the method invoked by the provider in response to
+	# queries, and also the method to use to prefill the cache
+	# with holes.
+	unset -nocomplain myhit($key)
+	set              mymiss($key) .
+	$self NotifyUnset 0 $key
+	return
+    }
+
+    method NotifySet {found key} {
+	if {![info exists mywaiting($key)] || ![llength $mywaiting($key)]} return
+
+	set pending $mywaiting($key)
+	unset mywaiting($key)
+
+	set value $myhit($key)
+	if {$found && !$options(-full-async-results)} {
+	    foreach donecmd $pending {
+		uplevel \#0 [linsert $donecmd end set $key $value]
+	    }
+	} else {
+	    foreach donecmd $pending {
+		after idle [linsert $donecmd end set $key $value]
+	    }
+	}
+	return
+    }
+
+    method NotifyUnset {found key} {
+	if {![info exists mywaiting($key)] || ![llength $mywaiting($key)]} return
+
+	set pending $mywaiting($key)
+	unset mywaiting($key)
+
+	if {$found && !$options(-full-async-results)} {
+	    foreach donecmd $pending {
+		uplevel \#0 [linsert $donecmd end unset $key]
+	    }
+	} else {
+	    foreach donecmd $pending {
+		after idle [linsert $donecmd end unset $key]
+	    }
+	}
+	return
+    }
+
+    proc WrongArgs {expected} {
+	return -code error "wrong#args: Expected $expected"
+    }
+
+    # ### ### ### ######### ######### #########
+    ## State
+
+    variable myprovider          ; # Command prefix providing the data to cache.
+    variable myhit     -array {} ; # Cache array mapping keys to values.
+    variable mymiss    -array {} ; # Cache array mapping keys to holes.
+    variable mywaiting -array {} ; # Map of keys pending to notifier commands.
+
+    # ### ### ### ######### ######### #########
+}
+
+# ### ### ### ######### ######### #########
+## Ready
+
+package provide cache::async 0.3.2

src/vendorlib_tcl9/tcllib2.0/cache/pkgIndex.tcl

@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {return}
+package ifneeded cache::async 0.3.2 [list source [file join $dir async.tcl]]
+

src/vendorlib_tcl9/tcllib2.0/clay/pkgIndex.tcl

@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.6 9]} {return}
+package ifneeded clay 0.8.8 [list source [file join $dir clay.tcl]]
+

src/vendorlib_tcl9/tcllib2.0/clock/iso8601.tcl

@@ -0,0 +1,280 @@
+## -*- tcl -*-
+# # ## ### ##### ######## ############# #####################
+## Copyright (c) 2004 Kevin Kenny
+## Origin http://wiki.tcl.tk/13094
+## Modified for Tcl 8.5 only (eval -> {*}).
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5 9
+package provide clock::iso8601 0.2
+namespace eval ::clock::iso8601 {}
+
+# # ## ### ##### ######## ############# #####################
+## API
+
+# iso8601::parse_date --
+#
+#       Parse an ISO8601 date/time string in an unknown variant.
+#
+# Parameters:
+#       string -- String to parse
+#       args -- Arguments as for [clock scan]; may include any of
+#               the '-base', '-gmt', '-locale' or '-timezone options.
+#
+# Results:
+#       Returns the given date in seconds from the Posix epoch.
+
+proc ::clock::iso8601::parse_date { string args } {
+    variable DatePatterns
+    variable Repattern
+    foreach { regex interpretation } $DatePatterns {
+	if { [regexp "^$regex\$" $string] } {
+	    #puts A|$string|\t|$regex|\t|$interpretation|
+
+	    # For incomplete dates (month and/or day missing), we have
+	    # to set our own default values to overcome clock scan's
+	    # settings. We do this by switching to a different pattern
+	    # and extending the input properly for that pattern.
+
+	    if {[dict exists $Repattern $interpretation]} {
+		lassign [dict get $Repattern $interpretation] interpretation adjust modifier
+		{*}$modifier
+		# adjust irrelevant here, see parse_time for use.
+	    }
+
+	    #puts B|$string|\t|$regex|\t|$interpretation|
+	    return [clock scan $string -format $interpretation {*}$args]
+	}
+    }
+    return -code error "not an iso8601 date string"
+}
+
+# iso8601::parse_time --
+#
+#       Parse a point-in-time in ISO8601 format
+#
+# Parameters:
+#       string -- String to parse
+#       args -- Arguments as for [clock scan]; may include any of
+#               the '-base', '-gmt', '-locale' or '-timezone options.
+#
+# Results:
+#       Returns the given time in seconds from the Posix epoch.
+
+proc ::clock::iso8601::parse_time { string args } {
+    variable DatePatterns
+    variable Repattern
+    if {![MatchTime $string field]} {
+	return -code error "not an iso8601 time string"
+    }
+
+    #parray field
+    #puts A|$string|
+
+    set pattern {}
+    foreach {regex interpretation} $DatePatterns {
+	if {[Has $interpretation tstart]} {
+	    append pattern $interpretation
+	}
+    }
+
+    if {[dict exists $Repattern $pattern]} {
+	lassign [dict get $Repattern $pattern] interpretation adjust modifier
+	{*}$modifier
+	incr tstart $adjust
+    }
+
+    append pattern [Get T len]
+    incr tstart $len
+
+    if {[Has %H tstart]} {
+	append pattern %H [Get Hcolon len]
+	incr tstart $len
+
+	if {[Has %M tstart]} {
+	    append pattern %M [Get Mcolon len]
+	    incr tstart $len
+
+	    if {[Has %S tstart]} {
+		append pattern %S
+	    } else {
+		# No seconds, default to start of minute.
+		append pattern %S
+		Insert string $tstart 00
+	    }
+	} else {
+	    # No minutes, nor seconds, default to start of hour.
+	    append pattern %M%S
+	    Insert string $tstart 0000
+	}
+    } else {
+	# No time information, default to midnight.
+	append pattern %H%M%S
+	Insert string $tstart 000000
+    }
+    if {[Has %Z _]} {
+	append pattern %Z
+    }
+
+    #puts B|$string|\t|$pattern|
+    return [clock scan $string -format $pattern {*}$args]
+}
+
+# # ## ### ##### ######## ############# #####################
+
+proc ::clock::iso8601::Get {x lv} {
+    upvar 1 field field string string $lv len
+    lassign $field($x) s e
+    if {($s >= 0) && ($e >= 0)} {
+	set len [expr {$e - $s + 1}]
+	return [string range $string $s $e]
+    }
+    set len 0
+    return ""
+
+}
+
+proc ::clock::iso8601::Has {x nv} {
+    upvar 1 field field string string $nv next
+    lassign $field($x) s e
+    if {($s >= 0) && ($e >= 0)} {
+	set  next $e
+	incr next
+	return 1
+    }
+    return 0
+}
+
+proc ::clock::iso8601::Insert {sv index str} {
+    upvar 1 $sv string
+    append r [string range $string 0 ${index}-1]
+    append r $str
+    append r [string range $string $index end]
+    set string $r
+    return
+}
+
+# # ## ### ##### ######## ############# #####################
+## State
+
+namespace eval ::clock::iso8601 {
+
+    namespace export parse_date parse_time
+    namespace ensemble create
+
+    # Enumerate the patterns that we recognize for an ISO8601 date as both
+    # the regexp patterns that match them and the [clock] patterns that scan
+    # them.
+
+    variable DatePatterns {
+	{\d\d\d\d-\d\d-\d\d}            {%Y-%m-%d}
+	{\d\d\d\d\d\d\d\d}              {%Y%m%d}
+	{\d\d\d\d-\d\d\d}               {%Y-%j}
+	{\d\d\d\d\d\d\d}                {%Y%j}
+	{\d\d-\d\d-\d\d}                {%y-%m-%d}
+	{\d\d\d\d-\d\d}                 {%Y-%m}
+	{\d\d\d\d\d\d}                  {%y%m%d}
+	{\d\d-\d\d\d}                   {%y-%j}
+	{\d\d\d\d\d}                    {%y%j}
+	{--\d\d-\d\d}                   {--%m-%d}
+	{--\d\d\d\d}                    {--%m%d}
+	{--\d\d\d}                      {--%j}
+	{---\d\d}                       {---%d}
+	{\d\d\d\d-W\d\d-\d}             {%G-W%V-%u}
+	{\d\d\d\dW\d\d\d}               {%GW%V%u}
+	{\d\d-W\d\d-\d}                 {%g-W%V-%u}
+	{\d\dW\d\d\d}                   {%gW%V%u}
+	{\d\d\d\d-W\d\d}                {%G-W%V}
+	{\d\d\d\dW\d\d}                 {%GW%V}
+	{-W\d\d-\d}                     {-W%V-%u}
+	{-W\d\d\d}                      {-W%V%u}
+	{-W-\d}                         {%u}
+	{\d\d\d\d}                      {%Y}
+    }
+
+    # Dictionary of the patterns requiring modifications to the input
+    # for proper month and/or day defaults.
+    variable Repattern {
+	%Y-%m  {%Y-%m-%d  3 {Insert string 7 -01}}
+	%Y     {%Y-%m-%d  5 {Insert string 4 -01-01}}
+	%G-W%V {%G-W%V-%u 1 {Insert string 8 -1}}
+	%GW%V  {%GW%V%u   1 {Insert string 6 1}}
+    }
+}
+
+# # ## ### ##### ######## ############# #####################
+## Initialization
+
+apply {{} {
+    # MatchTime -- (constructed procedure)
+    #
+    #   Match an ISO8601 date/time string and indicate how it matched.
+    #
+    # Parameters:
+    #   string -- String to match.
+    #   fieldArray -- Name of an array in caller's scope that will receive
+    #                 parsed fields of the time.
+    #
+    # Results:
+    #   Returns 1 if the time was scanned successfully, 0 otherwise.
+    #
+    # Side effects:
+    #   Initializes the field array.  The keys that are significant:
+    #           - Any date pattern in 'DatePatterns' indicates that the
+    #             corresponding value, if non-empty, contains a date string
+    #             in the given format.
+    #           - The patterns T, Hcolon, and Mcolon indicate a literal
+    #             T preceding the time, a colon following the hour, or
+    #             a colon following the minute.
+    #           - %H, %M, %S, and %Z indicate the presence of the
+    #             corresponding parts of the time.
+
+    variable DatePatterns
+
+    set cmd {regexp -indices -expanded -nocase -- {PATTERN} $timeString ->}
+    set re \(?:\(?:
+    set sep {}
+    foreach {regex interpretation} $DatePatterns {
+	append re $sep \( $regex \)
+	append cmd " " [list field($interpretation)]
+	set sep |
+    }
+    append re \) {(T|[[:space:]]+)} \)?
+    append cmd { field(T)}
+    append re {(\d\d)(?:(:?)(\d\d)(?:(:?)(\d\d)?))?}
+    append cmd { field(%H) field(Hcolon) } {field(%M) field(Mcolon) field(%S)}
+    append re {[[:space:]]*(Z|[-+]\d\d:?\d\d)?}
+    append cmd { field(%Z)}
+    set cmd [string map [list {{PATTERN}} [list $re]] \
+		 $cmd]
+
+    proc MatchTime { timeString fieldArray } "
+             upvar 1 \$fieldArray field
+             $cmd
+         "
+
+    #puts [info body MatchTime]
+
+} ::clock::iso8601}
+
+# # ## ### ##### ######## ############# #####################
+
+return
+# Usage examples, disabled.
+
+if { [info exists ::argv0] && ( $::argv0 eq [info script] ) } {
+    puts "::clock::iso8601::parse_date"
+    puts [::clock::iso8601::parse_date 1970-01-02 -timezone :UTC]
+    puts [::clock::iso8601::parse_date 1970-W01-5 -timezone :UTC]
+    puts [time {::clock::iso8601::parse_date 1970-01-02 -timezone :UTC} 1000]
+    puts [time {::clock::iso8601::parse_date 1970-W01-5 -timezone :UTC} 1000]
+    puts "::clock::iso8601::parse_time"
+    puts [clock format [::clock::iso8601::parse_time 2004-W33-2T18:52:24Z] \
+	      -format {%X %x %z} -locale system]
+    puts [clock format [::clock::iso8601::parse_time 18:52:24Z] \
+	      -format {%X %x %z} -locale system]
+    puts [time {::clock::iso8601::parse_time 2004-W33-2T18:52:24Z} 1000]
+    puts [time {::clock::iso8601::parse_time 18:52:24Z} 1000]
+}

src/vendorlib_tcl9/tcllib2.0/clock/pkgIndex.tcl

@@ -0,0 +1,3 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {return}
+package ifneeded clock::rfc2822 0.2 [list source [file join $dir rfc2822.tcl]]
+package ifneeded clock::iso8601 0.2 [list source [file join $dir iso8601.tcl]]

src/vendorlib_tcl9/tcllib2.0/clock/rfc2822.tcl

@@ -0,0 +1,214 @@
+## -*- tcl -*-
+# # ## ### ##### ######## ############# #####################
+## Copyright (c) 2004 Kevin Kenny
+## Origin http://wiki.tcl.tk/24074
+
+# # ## ### ##### ######## ############# #####################
+## Requisites
+
+package require Tcl 8.5 9
+package provide clock::rfc2822 0.2
+namespace eval ::clock::rfc2822 {}
+
+# # ## ### ##### ######## ############# #####################
+## API
+
+# ::clock::rfc2822::parse_date --
+#
+#       Parses a date expressed in RFC2822 format
+#
+# Parameters:
+#       date - The date to parse
+#
+# Results:
+#       Returns the date expressed in seconds from the Epoch, or throws
+#       an error if the date could not be parsed.
+
+proc ::clock::rfc2822::parse_date { date } {
+    variable datepats
+
+    # Strip comments and excess whitespace from the date field
+
+    regsub -all -expanded {
+        \(              # open parenthesis
+        (:?
+	 [^()[.\.]]     # character other than ()\
+	     |\\.       # or backslash escape
+	 )*             # any number of times
+        \)              # close paren
+    } $date {} date
+    set date [string trim $date]
+
+    # Match the patterns in order of preference, returning the first success
+
+    foreach {regexp pat} $datepats {
+        if { [regexp -nocase $regexp $date] } {
+            return [clock scan $date -format $pat]
+        }
+    }
+
+    return -code error -errorcode {CLOCK RFC2822 BADDATE} \
+        "expected an RFC2822 date, got \"$date\""
+}
+
+
+# # ## ### ##### ######## ############# #####################
+## Internals, transient, removed after initialization.
+
+# AddDatePat --
+#
+#       Internal procedure that adds a date pattern to the pattern list
+#
+# Parameters:
+#       wpat - Regexp pattern that matches the weekday
+#       wgrp - Format group that matches the weekday
+#       ypat - Regexp pattern that matches the year
+#       ygrp - Format group that matches the year
+#       mdpat - Regexp pattern that matches month and day
+#       mdgrp - Format group that matches month and day
+#       spat - Regexp pattern that matches the seconds of the minute
+#       sgrp - Format group that matches the seconds of the minute
+#       zpat - Regexp pattern that matches the time zone
+#       zgrp - Format group that matches the time zone
+#
+# Results:
+#       None
+#
+# Side effects:
+#       Adds a complete regexp and a complete [clock scan] pattern to
+#       'datepats'
+
+proc ::clock::rfc2822::AddDatePat { wpat wgrp ypat ygrp mdpat mdgrp
+				    spat sgrp zpat zgrp } {
+    variable datepats
+
+    set regexp {^[[:space:]]*}
+    set pat {}
+    append regexp $wpat $mdpat {[[:space:]]+} $ypat
+    append pat $wgrp $mdgrp $ygrp
+    append regexp {[[:space:]]+\d\d?:\d\d} $spat
+    append pat { %H:%M} $sgrp
+    append regexp $zpat
+    append pat $zgrp
+    append regexp {[[:space:]]*$}
+    lappend datepats $regexp $pat
+    return
+}
+
+# InitDatePats --
+#
+#       Internal procedure that initializes the set of date patterns
+# 	allowed in an RFC2822 date
+#
+# Parameters:
+#       permissible - 1 if erroneous (but common) time zones are to be
+#                     allowed, 0 if they are to be rejected
+#
+# Results:
+#       None.
+#
+# Side effects:
+
+proc ::clock::rfc2822::InitDatePats { permissible } {
+    # Produce formats for the observed variants of RFC 2822 dates.
+    # Permissible variants come first in the list; impermissible ones
+    # come later.
+
+    # The month and day may be "%b %d" or "%d %b"
+
+    foreach mdpat {{[[:alpha:]]+[[:space:]]+\d\d?}
+        {\d\d?[[:space:]]+[[:alpha:]]+}} \
+        mdgrp {{%b %d} {%d %b}} \
+        mdperm {0 1} {
+            # The year may be two digits, or four. Four digit year is
+            # done first.
+
+            foreach ypat {{\d\d\d\d} {\d\d}} ygrp {%Y %y} {
+                # The seconds of the minute may be provided, or
+                # omitted.
+
+                foreach spat {{:\d\d} {}} sgrp {:%S {}} {
+                    # The weekday may be provided or omitted. It is
+                    # common but impermissible to omit the comma after
+                    # the weekday name.
+
+                    foreach wpat {
+                        {(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un)),[[:space:]]+}
+                        {(?:Mon|T(?:ue|hu)|Wed|Fri|S(?:at|un))[[:space:]]+}
+                        {}
+                    } wgrp {
+                        {%a, }
+                        {%a }
+                        {}
+                    } wperm {
+                        1
+                        0
+                        1
+                    } {
+                        # Time zone is defined as +/- hhmm, or as a
+                        # named time zone.  Other common but buggy
+                        # formats are GMT+-hh:mm, a time zone name in
+                        # quotation marks, and complete omission of
+                        # the time zone.
+
+                        foreach zpat {
+                            {[[:space:]]+(?:[-+]\d\d\d\d|[[:alpha:]]+)}
+                            {[[:space:]]+GMT[-+]\d\d:?\d\d}
+                            {[[:space:]]+"[[:alpha:]]+"}
+                            {}
+                        } zgrp {
+                            { %Z}
+                            { GMT%Z}
+                            { "%Z"}
+                            {}
+                        } zperm {
+                            1
+                            0
+                            0
+                            0
+                        } {
+                            if { ($zperm && $wperm && $mdperm)
+                                 == $permissible } {
+                                AddDatePat $wpat $wgrp $ypat $ygrp \
+                                    $mdpat $mdgrp \
+                                    $spat $sgrp $zpat $zgrp
+                            }
+                        }
+                    }
+                }
+            }
+        }
+    return
+}
+
+# # ## ### ##### ######## ############# #####################
+## State
+
+namespace eval ::clock::rfc2822 {
+    namespace export parse_date
+    namespace ensemble create
+
+    variable datepats {}
+}
+
+# # ## ### ##### ######## ############# #####################
+# Initialize the date patterns
+
+namespace eval ::clock::rfc2822 {
+    InitDatePats 1
+    InitDatePats 0
+    rename AddDatePat {}
+    rename InitDatePats {}
+    #puts [join $datepats \n]
+}
+
+# # ## ### ##### ######## ############# #####################
+
+return
+# Usage example, disabled
+
+if {![info exists ::argv0] || [info script] ne $::argv0} return
+puts [clock format \
+          [::clock::rfc2822::parse_date {Mon(day), 23 Aug(ust) 2004 01:23:45 UT}]]
+puts [clock format \
+          [::clock::rfc2822::parse_date "Tue, Jul 21 2009 19:37:47 GMT-0400"]]

src/vendorlib_tcl9/tcllib2.0/cmdline/cmdline.tcl

@@ -0,0 +1,933 @@
+# cmdline.tcl --
+#
+#	This package provides a utility for parsing command line
+#	arguments that are processed by our various applications.
+#	It also includes a utility routine to determine the
+#	application name for use in command line errors.
+#
+# Copyright (c) 1998-2000 by Ajuba Solutions.
+# Copyright (c) 2001-2015 by Andreas Kupries <andreas_kupries@users.sf.net>.
+# Copyright (c) 2003      by David N. Welton  <davidw@dedasys.com>
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require Tcl 8.5 9
+package provide cmdline 1.5.3
+
+namespace eval ::cmdline {
+    namespace export getArgv0 getopt getKnownOpt getfiles getoptions \
+	    getKnownOptions usage
+}
+
+# ::cmdline::getopt --
+#
+#	The cmdline::getopt works in a fashion like the standard
+#	C based getopt function.  Given an option string and a
+#	pointer to an array or args this command will process the
+#	first argument and return info on how to proceed.
+#
+# Arguments:
+#	argvVar		Name of the argv list that you
+#			want to process.  If options are found the
+#			arg list is modified and the processed arguments
+#			are removed from the start of the list.
+#	optstring	A list of command options that the application
+#			will accept.  If the option ends in ".arg" the
+#			getopt routine will use the next argument as
+#			an argument to the option.  Otherwise the option
+#			is a boolean that is set to 1 if present.
+#	optVar		The variable pointed to by optVar
+#			contains the option that was found (without the
+#			leading '-' and without the .arg extension).
+#	valVar		Upon success, the variable pointed to by valVar
+#			contains the value for the specified option.
+#			This value comes from the command line for .arg
+#			options, otherwise the value is 1.
+#			If getopt fails, the valVar is filled with an
+#			error message.
+#
+# Results:
+# 	The getopt function returns 1 if an option was found, 0 if no more
+# 	options were found, and -1 if an error occurred.
+
+proc ::cmdline::getopt {argvVar optstring optVar valVar} {
+    upvar 1 $argvVar argsList
+    upvar 1 $optVar option
+    upvar 1 $valVar value
+
+    set result [getKnownOpt argsList $optstring option value]
+
+    if {$result < 0} {
+        # Collapse unknown-option error into any-other-error result.
+        set result -1
+    }
+    return $result
+}
+
+# ::cmdline::getKnownOpt --
+#
+#	The cmdline::getKnownOpt works in a fashion like the standard
+#	C based getopt function.  Given an option string and a
+#	pointer to an array or args this command will process the
+#	first argument and return info on how to proceed.
+#
+# Arguments:
+#	argvVar		Name of the argv list that you
+#			want to process.  If options are found the
+#			arg list is modified and the processed arguments
+#			are removed from the start of the list.  Note that
+#			unknown options and the args that follow them are
+#			left in this list.
+#	optstring	A list of command options that the application
+#			will accept.  If the option ends in ".arg" the
+#			getopt routine will use the next argument as
+#			an argument to the option.  Otherwise the option
+#			is a boolean that is set to 1 if present.
+#	optVar		The variable pointed to by optVar
+#			contains the option that was found (without the
+#			leading '-' and without the .arg extension).
+#	valVar		Upon success, the variable pointed to by valVar
+#			contains the value for the specified option.
+#			This value comes from the command line for .arg
+#			options, otherwise the value is 1.
+#			If getopt fails, the valVar is filled with an
+#			error message.
+#
+# Results:
+# 	The getKnownOpt function returns 1 if an option was found,
+#	0 if no more options were found, -1 if an unknown option was
+#	encountered, and -2 if any other error occurred.
+
+proc ::cmdline::getKnownOpt {argvVar optstring optVar valVar} {
+    upvar 1 $argvVar argsList
+    upvar 1 $optVar  option
+    upvar 1 $valVar  value
+
+    # default settings for a normal return
+    set value ""
+    set option ""
+    set result 0
+
+    # check if we're past the end of the args list
+    if {[llength $argsList] != 0} {
+
+	# if we got -- or an option that doesn't begin with -, return (skipping
+	# the --).  otherwise process the option arg.
+	switch -glob -- [set arg [lindex $argsList 0]] {
+	    "--" {
+		set argsList [lrange $argsList 1 end]
+	    }
+	    "--*" -
+	    "-*" {
+		set option [string range $arg 1 end]
+		if {[string equal [string range $option 0 0] "-"]} {
+		    set option [string range $arg 2 end]
+		}
+
+		# support for format: [-]-option=value
+		set idx [string first "=" $option 1]
+		if {$idx != -1} {
+		    set _val   [string range $option [expr {$idx+1}] end]
+		    set option [string range $option 0   [expr {$idx-1}]]
+		}
+
+		if {[lsearch -exact $optstring $option] != -1} {
+		    # Booleans are set to 1 when present
+		    set value 1
+		    set result 1
+		    set argsList [lrange $argsList 1 end]
+		} elseif {[lsearch -exact $optstring "$option.arg"] != -1} {
+		    set result 1
+		    set argsList [lrange $argsList 1 end]
+
+		    if {[info exists _val]} {
+			set value $_val
+		    } elseif {[llength $argsList]} {
+			set value [lindex $argsList 0]
+			set argsList [lrange $argsList 1 end]
+		    } else {
+			set value "Option \"$option\" requires an argument"
+			set result -2
+		    }
+		} else {
+		    # Unknown option.
+		    set value "Illegal option \"-$option\""
+		    set result -1
+		}
+	    }
+	    default {
+		# Skip ahead
+	    }
+	}
+    }
+
+    return $result
+}
+
+# ::cmdline::getoptions --
+#
+#	Process a set of command line options, filling in defaults
+#	for those not specified.  This also generates an error message
+#	that lists the allowed flags if an incorrect flag is specified.
+#
+# Arguments:
+#	argvVar		The name of the argument list, typically argv.
+#			We remove all known options and their args from it.
+#                       In other words, after the call to this command the
+#                       referenced variable contains only the non-options,
+#                       and unknown options.
+#	optlist		A list-of-lists where each element specifies an option
+#			in the form:
+#				(where flag takes no argument)
+#					flag comment
+#
+#				(or where flag takes an argument)
+#					flag default comment
+#
+#			If flag ends in ".arg" then the value is taken from the
+#			command line. Otherwise it is a boolean and appears in
+#			the result if present on the command line. If flag ends
+#			in ".secret", it will not be displayed in the usage.
+#	usage		Text to include in the usage display. Defaults to
+#			"options:"
+#
+# Results
+#	Name value pairs suitable for using with array set.
+#       A modified `argvVar`.
+
+proc ::cmdline::getoptions {argvVar optlist {usage options:}} {
+    upvar 1 $argvVar argv
+
+    set opts [GetOptionDefaults $optlist result]
+
+    set argc [llength $argv]
+    while {[set err [getopt argv $opts opt arg]]} {
+	if {$err < 0} {
+            set result(?) ""
+            break
+	}
+	set result($opt) $arg
+    }
+    if {[info exist result(?)] || [info exists result(help)]} {
+	Error [usage $optlist $usage] USAGE
+    }
+    return [array get result]
+}
+
+# ::cmdline::getKnownOptions --
+#
+#	Process a set of command line options, filling in defaults
+#	for those not specified.  This ignores unknown flags, but generates
+#	an error message that lists the correct usage if a known option
+#	is used incorrectly.
+#
+# Arguments:
+#	argvVar		The name of the argument list, typically argv.  This
+#			We remove all known options and their args from it.
+#                       In other words, after the call to this command the
+#                       referenced variable contains only the non-options,
+#                       and unknown options.
+#	optlist		A list-of-lists where each element specifies an option
+#			in the form:
+#				flag default comment
+#			If flag ends in ".arg" then the value is taken from the
+#			command line. Otherwise it is a boolean and appears in
+#			the result if present on the command line. If flag ends
+#			in ".secret", it will not be displayed in the usage.
+#	usage		Text to include in the usage display. Defaults to
+#			"options:"
+#
+# Results
+#	Name value pairs suitable for using with array set.
+#       A modified `argvVar`.
+
+proc ::cmdline::getKnownOptions {argvVar optlist {usage options:}} {
+    upvar 1 $argvVar argv
+
+    set opts [GetOptionDefaults $optlist result]
+
+    # As we encounter them, keep the unknown options and their
+    # arguments in this list.  Before we return from this procedure,
+    # we'll prepend these args to the argList so that the application
+    # doesn't lose them.
+
+    set unknownOptions [list]
+
+    set argc [llength $argv]
+    while {[set err [getKnownOpt argv $opts opt arg]]} {
+	if {$err == -1} {
+            # Unknown option.
+
+            # Skip over any non-option items that follow it.
+            # For now, add them to the list of unknownOptions.
+            lappend unknownOptions [lindex $argv 0]
+            set argv [lrange $argv 1 end]
+            while {([llength $argv] != 0) \
+                    && ![string match "-*" [lindex $argv 0]]} {
+                lappend unknownOptions [lindex $argv 0]
+                set argv [lrange $argv 1 end]
+            }
+	} elseif {$err == -2} {
+            set result(?) ""
+            break
+        } else {
+            set result($opt) $arg
+        }
+    }
+
+    # Before returning, prepend the any unknown args back onto the
+    # argList so that the application doesn't lose them.
+    set argv [concat $unknownOptions $argv]
+
+    if {[info exist result(?)] || [info exists result(help)]} {
+	Error [usage $optlist $usage] USAGE
+    }
+    return [array get result]
+}
+
+# ::cmdline::GetOptionDefaults --
+#
+#	This internal procedure processes the option list (that was passed to
+#	the getopt or getKnownOpt procedure).  The defaultArray gets an index
+#	for each option in the option list, the value of which is the option's
+#	default value.
+#
+# Arguments:
+#	optlist		A list-of-lists where each element specifies an option
+#			in the form:
+#				flag default comment
+#			If flag ends in ".arg" then the value is taken from the
+#			command line. Otherwise it is a boolean and appears in
+#			the result if present on the command line. If flag ends
+#			in ".secret", it will not be displayed in the usage.
+#	defaultArrayVar	The name of the array in which to put argument defaults.
+#
+# Results
+#	Name value pairs suitable for using with array set.
+
+proc ::cmdline::GetOptionDefaults {optlist defaultArrayVar} {
+    upvar 1 $defaultArrayVar result
+
+    set opts {? help}
+    foreach opt $optlist {
+	set name [lindex $opt 0]
+	if {[regsub -- {\.secret$} $name {} name] == 1} {
+	    # Need to hide this from the usage display and getopt
+	}
+	lappend opts $name
+	if {[regsub -- {\.arg$} $name {} name] == 1} {
+
+	    # Set defaults for those that take values.
+
+	    set default [lindex $opt 1]
+	    set result($name) $default
+	} else {
+	    # The default for booleans is false
+	    set result($name) 0
+	}
+    }
+    return $opts
+}
+
+# ::cmdline::usage --
+#
+#	Generate an error message that lists the allowed flags.
+#
+# Arguments:
+#	optlist		As for cmdline::getoptions
+#	usage		Text to include in the usage display. Defaults to
+#			"options:"
+#
+# Results
+#	A formatted usage message
+
+proc ::cmdline::usage {optlist {usage {options:}}} {
+    set str "[getArgv0] $usage\n"
+    set longest 20
+    set lines {}
+    foreach opt [concat $optlist \
+	     {{- "Forcibly stop option processing"} {help "Print this message"} {? "Print this message"}}] {
+	set name "-[lindex $opt 0]"
+	if {[regsub -- {\.secret$} $name {} name] == 1} {
+	    # Hidden option
+	    continue
+	}
+	if {[regsub -- {\.arg$} $name {} name] == 1} {
+	    append name " value"
+	    set desc "[lindex $opt 2] <[lindex $opt 1]>"
+	} else {
+	    set desc "[lindex $opt 1]"
+	}
+	set n [string length $name]
+	if {$n > $longest} { set longest $n }
+	# max not available before 8.5 - set longest [expr {max($longest, )}]
+	lappend lines $name $desc
+    }
+    foreach {name desc} $lines {
+	append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n"
+    }
+
+    return $str
+}
+
+# ::cmdline::getfiles --
+#
+#	Given a list of file arguments from the command line, compute
+#	the set of valid files.  On windows, file globbing is performed
+#	on each argument.  On Unix, only file existence is tested.  If
+#	a file argument produces no valid files, a warning is optionally
+#	generated.
+#
+#	This code also uses the full path for each file.  If not
+#	given it prepends [pwd] to the filename.  This ensures that
+#	these files will never conflict with files in our zip file.
+#
+# Arguments:
+#	patterns	The file patterns specified by the user.
+#	quiet		If this flag is set, no warnings will be generated.
+#
+# Results:
+#	Returns the list of files that match the input patterns.
+
+proc ::cmdline::getfiles {patterns quiet} {
+    set result {}
+    if {$::tcl_platform(platform) == "windows"} {
+	foreach pattern $patterns {
+	    set pat [file join $pattern]
+	    set files [glob -nocomplain -- $pat]
+	    if {$files == {}} {
+		if {! $quiet} {
+		    puts stdout "warning: no files match \"$pattern\""
+		}
+	    } else {
+		foreach file $files {
+		    lappend result $file
+		}
+	    }
+	}
+    } else {
+	set result $patterns
+    }
+    set files {}
+    foreach file $result {
+	# Make file an absolute path so that we will never conflict
+	# with files that might be contained in our zip file.
+	set fullPath [file join [pwd] $file]
+
+	if {[file isfile $fullPath]} {
+	    lappend files $fullPath
+	} elseif {! $quiet} {
+	    puts stdout "warning: no files match \"$file\""
+	}
+    }
+    return $files
+}
+
+# ::cmdline::getArgv0 --
+#
+#	This command returns the "sanitized" version of argv0.  It will strip
+#	off the leading path and remove the ".bin" extensions that our apps
+#	use because they must be wrapped by a shell script.
+#
+# Arguments:
+#	None.
+#
+# Results:
+#	The application name that can be used in error messages.
+
+proc ::cmdline::getArgv0 {} {
+    global argv0
+
+    set name [file tail $argv0]
+    return [file rootname $name]
+}
+
+##
+# ### ### ### ######### ######### #########
+##
+# Now the typed versions of the above commands.
+##
+# ### ### ### ######### ######### #########
+##
+
+# typedCmdline.tcl --
+#
+#    This package provides a utility for parsing typed command
+#    line arguments that may be processed by various applications.
+#
+# Copyright (c) 2000 by Ross Palmer Mohn.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: cmdline.tcl,v 1.28 2011/02/23 17:41:52 andreas_kupries Exp $
+
+namespace eval ::cmdline {
+    namespace export typedGetopt typedGetoptions typedUsage
+
+    # variable cmdline::charclasses --
+    #
+    #    Create regexp list of allowable character classes
+    #    from "string is" error message.
+    #
+    # Results:
+    #    String of character class names separated by "|" characters.
+
+    variable charclasses
+    #checker exclude badKey
+    catch {string is . .} charclasses
+    variable dummy
+    regexp      -- {must be (.+)$} $charclasses dummy charclasses
+    regsub -all -- {, (or )?}      $charclasses {|}   charclasses
+    unset dummy
+}
+
+# ::cmdline::typedGetopt --
+#
+#	The cmdline::typedGetopt works in a fashion like the standard
+#	C based getopt function.  Given an option string and a
+#	pointer to a list of args this command will process the
+#	first argument and return info on how to proceed. In addition,
+#	you may specify a type for the argument to each option.
+#
+# Arguments:
+#	argvVar		Name of the argv list that you want to process.
+#			If options are found, the arg list is modified
+#			and the processed arguments are removed from the
+#			start of the list.
+#
+#	optstring	A list of command options that the application
+#			will accept.  If the option ends in ".xxx", where
+#			xxx is any valid character class to the tcl
+#			command "string is", then typedGetopt routine will
+#			use the next argument as a typed argument to the
+#			option. The argument must match the specified
+#			character classes (e.g. integer, double, boolean,
+#			xdigit, etc.). Alternatively, you may specify
+#			".arg" for an untyped argument.
+#
+#	optVar		Upon success, the variable pointed to by optVar
+#			contains the option that was found (without the
+#			leading '-' and without the .xxx extension).  If
+#			typedGetopt fails the variable is set to the empty
+#			string. SOMETIMES! Different for each -value!
+#
+#	argVar		Upon success, the variable pointed to by argVar
+#			contains the argument for the specified option.
+#			If typedGetopt fails, the variable is filled with
+#			an error message.
+#
+# Argument type syntax:
+#	Option that takes no argument.
+#		foo
+#
+#	Option that takes a typeless argument.
+#		foo.arg
+#
+#	Option that takes a typed argument. Allowable types are all
+#	valid character classes to the tcl command "string is".
+#	Currently must be one of alnum, alpha, ascii, control,
+#	boolean, digit, double, false, graph, integer, lower, print,
+#	punct, space, true, upper, wordchar, or xdigit.
+#		foo.double
+#
+#	Option that takes an argument from a list.
+#		foo.(bar|blat)
+#
+# Argument quantifier syntax:
+#	Option that takes an optional argument.
+#		foo.arg?
+#
+#	Option that takes a list of arguments terminated by "--".
+#		foo.arg+
+#
+#	Option that takes an optional list of arguments terminated by "--".
+#		foo.arg*
+#
+#	Argument quantifiers work on all argument types, so, for
+#	example, the following is a valid option specification.
+#		foo.(bar|blat|blah)?
+#
+# Argument syntax miscellany:
+#	Options may be specified on the command line using a unique,
+#	shortened version of the option name. Given that program foo
+#	has an option list of {bar.alpha blah.arg blat.double},
+#	"foo -b fob" returns an error, but "foo -ba fob"
+#	successfully returns {bar fob}
+#
+# Results:
+#	The typedGetopt function returns one of the following:
+#	 1	a valid option was found
+#	 0	no more options found to process
+#	-1	invalid option
+#	-2	missing argument to a valid option
+#	-3	argument to a valid option does not match type
+#
+# Known Bugs:
+#	When using options which include special glob characters,
+#	you must use the exact option. Abbreviating it can cause
+#	an error in the "cmdline::prefixSearch" procedure.
+
+proc ::cmdline::typedGetopt {argvVar optstring optVar argVar} {
+    variable charclasses
+
+    upvar $argvVar argsList
+
+    upvar $optVar retvar
+    upvar $argVar optarg
+
+    # default settings for a normal return
+    set optarg ""
+    set retvar ""
+    set retval 0
+
+    # check if we're past the end of the args list
+    if {[llength $argsList] != 0} {
+
+        # if we got -- or an option that doesn't begin with -, return (skipping
+        # the --).  otherwise process the option arg.
+        switch -glob -- [set arg [lindex $argsList 0]] {
+            "--" {
+                set argsList [lrange $argsList 1 end]
+            }
+
+            "-*" {
+                # Create list of options without their argument extensions
+
+                set optstr ""
+                foreach str $optstring {
+                    lappend optstr [file rootname $str]
+                }
+
+                set _opt [string range $arg 1 end]
+
+                set i [prefixSearch $optstr [file rootname $_opt]]
+                if {$i != -1} {
+                    set opt [lindex $optstring $i]
+
+                    set quantifier "none"
+                    if {[regexp -- {\.[^.]+([?+*])$} $opt dummy quantifier]} {
+                        set opt [string range $opt 0 end-1]
+                    }
+
+                    if {[string first . $opt] == -1} {
+                        set retval 1
+                        set retvar $opt
+                        set argsList [lrange $argsList 1 end]
+
+                    } elseif {[regexp -- "\\.(arg|$charclasses)\$" $opt dummy charclass]
+                            || [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]} {
+				if {[string equal arg $charclass]} {
+                            set type arg
+			} elseif {[regexp -- "^($charclasses)\$" $charclass]} {
+                            set type class
+                        } else {
+                            set type oneof
+                        }
+
+                        set argsList [lrange $argsList 1 end]
+                        set opt [file rootname $opt]
+
+                        while {1} {
+                            if {[llength $argsList] == 0
+                                    || [string equal "--" [lindex $argsList 0]]} {
+                                if {[string equal "--" [lindex $argsList 0]]} {
+                                    set argsList [lrange $argsList 1 end]
+                                }
+
+                                set oneof ""
+                                if {$type == "arg"} {
+                                    set charclass an
+                                } elseif {$type == "oneof"} {
+                                    set oneof ", one of $charclass"
+                                    set charclass an
+                                }
+
+                                if {$quantifier == "?"} {
+                                    set retval 1
+                                    set retvar $opt
+                                    set optarg ""
+                                } elseif {$quantifier == "+"} {
+                                    set retvar $opt
+                                    if {[llength $optarg] < 1} {
+                                        set retval -2
+                                        set optarg "Option requires at least one $charclass argument$oneof -- $opt"
+                                    } else {
+                                        set retval 1
+                                    }
+                                } elseif {$quantifier == "*"} {
+                                    set retval 1
+                                    set retvar $opt
+                                } else {
+                                    set optarg "Option requires $charclass argument$oneof -- $opt"
+                                    set retvar $opt
+                                    set retval -2
+                                }
+                                set quantifier ""
+                            } elseif {($type == "arg")
+                                    || (($type == "oneof")
+                                    && [string first "|[lindex $argsList 0]|" "|$charclass|"] != -1)
+                                    || (($type == "class")
+                                    && [string is $charclass [lindex $argsList 0]])} {
+                                set retval 1
+                                set retvar $opt
+                                lappend optarg [lindex $argsList 0]
+                                set argsList [lrange $argsList 1 end]
+                            } else {
+                                set oneof ""
+                                if {$type == "arg"} {
+                                    set charclass an
+                                } elseif {$type == "oneof"} {
+                                    set oneof ", one of $charclass"
+                                    set charclass an
+                                }
+                                set optarg "Option requires $charclass argument$oneof -- $opt"
+                                set retvar $opt
+                                set retval -3
+
+                                if {$quantifier == "?"} {
+                                    set retval 1
+                                    set optarg ""
+                                }
+                                set quantifier ""
+                            }
+                             if {![regexp -- {[+*]} $quantifier]} {
+                                break;
+                            }
+                        }
+                    } else {
+                        Error \
+			    "Illegal option type specification: must be one of $charclasses" \
+			    BAD OPTION TYPE
+                    }
+                } else {
+                    set optarg "Illegal option -- $_opt"
+                    set retvar $_opt
+                    set retval -1
+                }
+            }
+	    default {
+		# Skip ahead
+	    }
+        }
+    }
+
+    return $retval
+}
+
+# ::cmdline::typedGetoptions --
+#
+#	Process a set of command line options, filling in defaults
+#	for those not specified. This also generates an error message
+#	that lists the allowed options if an incorrect option is
+#	specified.
+#
+# Arguments:
+#	argvVar		The name of the argument list, typically argv
+#	optlist		A list-of-lists where each element specifies an option
+#			in the form:
+#
+#				option default comment
+#
+#			Options formatting is as described for the optstring
+#			argument of typedGetopt. Default is for optionally
+#			specifying a default value. Comment is for optionally
+#			specifying a comment for the usage display. The
+#			options "--", "-help", and "-?" are automatically included
+#			in optlist.
+#
+# Argument syntax miscellany:
+#	Options formatting and syntax is as described in typedGetopt.
+#	There are two additional suffixes that may be applied when
+#	passing options to typedGetoptions.
+#
+#	You may add ".multi" as a suffix to any option. For options
+#	that take an argument, this means that the option may be used
+#	more than once on the command line and that each additional
+#	argument will be appended to a list, which is then returned
+#	to the application.
+#		foo.double.multi
+#
+#	If a non-argument option is specified as ".multi", it is
+#	toggled on and off for each time it is used on the command
+#	line.
+#		foo.multi
+#
+#	If an option specification does not contain the ".multi"
+#	suffix, it is not an error to use an option more than once.
+#	In this case, the behavior for options with arguments is that
+#	the last argument is the one that will be returned. For
+#	options that do not take arguments, using them more than once
+#	has no additional effect.
+#
+#	Options may also be hidden from the usage display by
+#	appending the suffix ".secret" to any option specification.
+#	Please note that the ".secret" suffix must be the last suffix,
+#	after any argument type specification and ".multi" suffix.
+#		foo.xdigit.multi.secret
+#
+# Results
+#	Name value pairs suitable for using with array set.
+
+proc ::cmdline::typedGetoptions {argvVar optlist {usage options:}} {
+    variable charclasses
+
+    upvar 1 $argvVar argv
+
+    set opts {? help}
+    foreach opt $optlist {
+        set name [lindex $opt 0]
+        if {[regsub -- {\.secret$} $name {} name] == 1} {
+            # Remove this extension before passing to typedGetopt.
+        }
+        if {[regsub -- {\.multi$} $name {} name] == 1} {
+            # Remove this extension before passing to typedGetopt.
+
+            regsub -- {\..*$} $name {} temp
+            set multi($temp) 1
+        }
+        lappend opts $name
+        if {[regsub -- "\\.(arg|$charclasses|\\(.+).?\$" $name {} name] == 1} {
+            # Set defaults for those that take values.
+            # Booleans are set just by being present, or not
+
+            set dflt [lindex $opt 1]
+            if {$dflt != {}} {
+                set defaults($name) $dflt
+            }
+        }
+    }
+    set argc [llength $argv]
+    while {[set err [typedGetopt argv $opts opt arg]]} {
+        if {$err == 1} {
+            if {[info exists result($opt)]
+                    && [info exists multi($opt)]} {
+                # Toggle boolean options or append new arguments
+
+                if {$arg == ""} {
+                    unset result($opt)
+                } else {
+                    set result($opt) "$result($opt) $arg"
+                }
+            } else {
+                set result($opt) "$arg"
+            }
+        } elseif {($err == -1) || ($err == -3)} {
+            Error [typedUsage $optlist $usage] USAGE
+        } elseif {$err == -2 && ![info exists defaults($opt)]} {
+            Error [typedUsage $optlist $usage] USAGE
+        }
+    }
+    if {[info exists result(?)] || [info exists result(help)]} {
+        Error [typedUsage $optlist $usage] USAGE
+    }
+    foreach {opt dflt} [array get defaults] {
+        if {![info exists result($opt)]} {
+            set result($opt) $dflt
+        }
+    }
+    return [array get result]
+}
+
+# ::cmdline::typedUsage --
+#
+#	Generate an error message that lists the allowed flags,
+#	type of argument taken (if any), default value (if any),
+#	and an optional description.
+#
+# Arguments:
+#	optlist		As for cmdline::typedGetoptions
+#
+# Results
+#	A formatted usage message
+
+proc ::cmdline::typedUsage {optlist {usage {options:}}} {
+    variable charclasses
+
+    set str "[getArgv0] $usage\n"
+    set longest 20
+    set lines {}
+    foreach opt [concat $optlist \
+            {{help "Print this message"} {? "Print this message"}}] {
+        set name "-[lindex $opt 0]"
+        if {[regsub -- {\.secret$} $name {} name] == 1} {
+            # Hidden option
+	    continue
+	}
+
+	if {[regsub -- {\.multi$} $name {} name] == 1} {
+	    # Display something about multiple options
+	}
+
+	if {[regexp -- "\\.(arg|$charclasses)\$" $name dummy charclass] ||
+	    [regexp -- {\.\(([^)]+)\)} $opt dummy charclass]
+	} {
+	    regsub -- "\\..+\$" $name {} name
+	    append name " $charclass"
+	    set desc [lindex $opt 2]
+	    set default [lindex $opt 1]
+	    if {$default != ""} {
+		append desc " <$default>"
+	    }
+	} else {
+	    set desc [lindex $opt 1]
+	}
+	lappend accum $name $desc
+	set n [string length $name]
+	if {$n > $longest} { set longest $n }
+	# max not available before 8.5 - set longest [expr {max($longest, [string length $name])}]
+    }
+    foreach {name desc} $accum {
+	append str "[string trimright [format " %-*s %s" $longest $name $desc]]\n"
+    }
+    return $str
+}
+
+# ::cmdline::prefixSearch --
+#
+#	Search a Tcl list for a pattern; searches first for an exact match,
+#	and if that fails, for a unique prefix that matches the pattern
+#	(i.e, first "lsearch -exact", then "lsearch -glob $pattern*"
+#
+# Arguments:
+#	list		list of words
+#	pattern		word to search for
+#
+# Results:
+#	Index of found word is returned. If no exact match or
+#	unique short version is found then -1 is returned.
+
+proc ::cmdline::prefixSearch {list pattern} {
+    # Check for an exact match
+
+    if {[set pos [::lsearch -exact $list $pattern]] > -1} {
+        return $pos
+    }
+
+    # Check for a unique short version
+
+    set slist [lsort $list]
+    if {[set pos [::lsearch -glob $slist $pattern*]] > -1} {
+        # What if there is nothing for the check variable?
+
+        set check [lindex $slist [expr {$pos + 1}]]
+        if {[string first $pattern $check] != 0} {
+            return [::lsearch -exact $list [lindex $slist $pos]]
+        }
+    }
+    return -1
+}
+# ::cmdline::Error --
+#
+#	Internal helper to throw errors with a proper error-code attached.
+#
+# Arguments:
+#	message		text of the error message to throw.
+#	args		additional parts of the error code to use,
+#                       with CMDLINE as basic prefix added by this command.
+#
+# Results:
+#	An error is thrown, always.
+
+proc ::cmdline::Error {message args} {
+    return -code error -errorcode [linsert $args 0 CMDLINE] $message
+}

src/vendorlib_tcl9/tcllib2.0/cmdline/pkgIndex.tcl

@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {return}
+package ifneeded cmdline 1.5.3 [list source [file join $dir cmdline.tcl]]

src/vendorlib_tcl9/tcllib2.0/comm/pkgIndex.tcl

@@ -0,0 +1,2 @@
+if {![package vsatisfies [package provide Tcl] 8.5 9]} {return}
+package ifneeded comm 4.7.3 [list source [file join $dir comm.tcl]]

src/vendorlib_tcl9/tcllib2.0/control/ascaller.tcl

@@ -0,0 +1,72 @@
+# ascaller.tcl - 
+#
+#       A few utility procs that manage the evaluation of a command
+#	or a script in the context of a caller, taking care of all 
+#	the ugly details of proper return codes, errorcodes, and
+#	a good stack trace in ::errorInfo as appropriate.
+# -------------------------------------------------------------------------
+#
+# RCS: @(#) $Id: ascaller.tcl,v 1.3 2004/01/15 06:36:12 andreas_kupries Exp $
+
+namespace eval ::control {
+
+    proc CommandAsCaller {cmdVar resultVar {where {}} {codeVar code}} {
+	set x [expr {[string equal "" $where] 
+		? {} : [subst -nobackslashes {\n    ($where)}]}]
+	set script [subst -nobackslashes -nocommands {
+	    set $codeVar [catch {uplevel 1 $$cmdVar} $resultVar]
+	    if {$$codeVar > 1} {
+		return -code $$codeVar $$resultVar
+	    }
+	    if {$$codeVar == 1} {
+		if {[string equal {"uplevel 1 $$cmdVar"} \
+			[lindex [split [set ::errorInfo] \n] end]]} {
+		    set $codeVar [join \
+			    [lrange [split [set ::errorInfo] \n] 0 \
+			    end-[expr {4+[llength [split $$cmdVar \n]]}]] \n]
+		} else {
+		    set $codeVar [join \
+			    [lrange [split [set ::errorInfo] \n] 0 end-1] \n]
+		}
+		return -code error -errorcode [set ::errorCode] \
+			-errorinfo "$$codeVar$x" $$resultVar
+	    }
+	}]
+	return $script
+    }
+
+    proc BodyAsCaller {bodyVar resultVar codeVar {where {}}} {
+	set x [expr {[string equal "" $where]
+		? {} : [subst -nobackslashes -nocommands \
+		{\n    ($where[string map {{    ("uplevel"} {}} \
+		[lindex [split [set ::errorInfo] \n] end]]}]}]
+	set script [subst -nobackslashes -nocommands {
+	    set $codeVar [catch {uplevel 1 $$bodyVar} $resultVar]
+	    if {$$codeVar == 1} {
+		if {[string equal {"uplevel 1 $$bodyVar"} \
+			[lindex [split [set ::errorInfo] \n] end]]} {
+		    set ::errorInfo [join \
+			    [lrange [split [set ::errorInfo] \n] 0 end-2] \n]
+		} 
+		set $codeVar [join \
+			[lrange [split [set ::errorInfo] \n] 0 end-1] \n]
+		return -code error -errorcode [set ::errorCode] \
+			-errorinfo "$$codeVar$x" $$resultVar
+	    }
+	}]
+	return $script
+    }
+
+    proc ErrorInfoAsCaller {find replace} {
+	set info $::errorInfo
+	set i [string last "\n    (\"$find" $info]
+	if {$i == -1} {return $info}
+	set result [string range $info 0 [incr i 6]]	;# keep "\n    (\""
+	append result $replace			;# $find -> $replace
+	incr i [string length $find]
+	set j [string first ) $info [incr i]]	;# keep rest of parenthetical
+	append result [string range $info $i $j]
+        return $result
+    }
+
+}