tidy vfs src/vfs/punk86old.vfs

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

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

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

@@ -1,188 +0,0 @@
-package provide app-punk 1.0
-
-#punk linerepl launcher
-
-#By the time we get here, we don't expect other packages to have been loaded - but the lib/module paths have already been scanned to populate 'package names'
-
-
-#Note regarding the use of package forget and binary packages
-#If the package has loaded a binary component - then a package forget and a subsequent package require can result in both binaries being present, as seen in 'info loaded' result - potentially resulting in anomalous behaviour
-#In general package forget after a package has already been required may need special handling and should be avoided where possible.
-#Only a limited set of package support unloading a binary component
-#We limit the use of 'package forget' here to packages that have not been loaded (whether pure-tcl or not)
-#ie in this context it is used only for manipulating preferences of which packages are loaded in the first place
-
-#Unintuitive preferencing can occur if the same package version is for example present in a tclkit and in a module or lib folder external to the kit.
-#It may be desired for performance or testing reasons to preference the library outside of the kit - and raising the version number may not always be possible/practical.
-
-#If the executable is a kit - we don't know what packages it contains or whether it allows loading from env based external paths. 
-#For app-punk projects - the lib/module paths based on the project being run should take preference, even if the version number is the same.
-#(these are the 'info nameofexecutable' or 'info script' or 'pwd' relative paths that are added here)
-#Some kits will remove lib/module paths (from auto_path & tcl::tm::list) that have been added via TCLLIBPATH / TCLX_Y_TM_PATH environment variables
-#Some kits will remove those env-provided lib paths but fail to remove the env-provided module paths
-#(differences in boot.tcl in the kits)
-
-#------------------------------------------------------------------------------
-#Module loading
-#------------------------------------------------------------------------------
-#If the current directory contains .tm files when the punk repl starts - then it will attempt to preference them
-# - but first add our other known relative modules paths - as it won't make sense to use current directory as a modulepath if it's an ancestor of one of these..
-
-set original_tm_list [tcl::tm::list]
-tcl::tm::remove {*}$original_tm_list
-
-set module_folders [list]
-
-#tm list first added end up later in the list - and then override earlier ones if version the same - so add pwd-relative 1st to give higher priority
-#(only if Tcl has scanned all paths - see below bogus package load)
-#1
-if {[file isdirectory [pwd]/modules]} {
-    catch {tcl::tm::add [pwd]/modules}
-}
-
-set tclmajorv [lindex [split [info tclversion] .] 0]
-
-#2)
-if {[string match "*.vfs/*" [file normalize [info script]]]} {
-    #src/xxx.vfs/lib/app-punk/repl.tcl
-    # assume if calling directly into .vfs that the user would prefer to preference the <project>/modules - so go up 4 levels
-    set basefolder [file dirname [file dirname [file dirname [file dirname [file normalize [info script]]]]]]
-    lappend module_folders [file join [file dirname $basefolder] modules] ;#modules folder at same level as src folder
-    lappend module_folders [file join [file dirname $basefolder] modules_tcl$tclmajorv]
-} else {
-    #  .../bin/punkXX.exe  look for ../modules  (i.e modules folder at same level as bin folder)
-    lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules
-    lappend module_folders [file dirname [file dirname [info nameofexecutable]]]/modules_tcl$tclmajorv
-}
-foreach modulefolder $module_folders {
-    if {[file isdirectory $modulefolder]} {
-        tcl::tm::add $modulefolder
-    } else {
-        puts stderr "Warning unable to find module folder at: $modulefolder"
-    }
-}
-
-
-
-#add lib and lib_tcl8 lib_tcl9 etc based on tclmajorv
-#libs are appended to end - so add higher priority libraries last (opposite to modules)
-#auto_path - add exe-relative after exe-relative path
-if {"windows" eq $::tcl_platform(platform)} {
-    #case differences dont matter - but can stop us finding path in auto_path
-    foreach libsub [list lib_tcl$tclmajorv lib] {
-        set libfolder [file dirname [file dirname [info nameofexecutable]]]/$libsub
-        if {[string tolower $libfolder] ni [string tolower $::auto_path]} {
-            if {[file isdirectory $libfolder]} {
-                lappend ::auto_path $libfolder
-            }
-        }
-        set libfolder [pwd]/$libsub
-        if {[string tolower $libfolder] ni [string tolower $::auto_path]} {
-            if {[file isdirectory $libfolder]} {
-                lappend ::auto_path $libfolder 
-            }
-        }
-    }
-} else {
-    #on other platforms, case differences could represent different paths
-    foreach libsub [list lib_tcl$tclmajorv lib] {
-        set libfolder [file dirname [file dirname [info nameofexecutable]]]/$libsub
-        if {$libfolder ni $::auto_path} {
-            if {[file isdirectory $libfolder]} {
-                lappend ::auto_path $libfolder
-            }
-        }
-        set libfolder [pwd]/$libsub
-        if {$libfolder ni $::auto_path} {
-            if {[file isdirectory $libfolder]} {
-                lappend ::auto_path $libfolder 
-            }
-        }
-    }
-}
-
-
-#2)
-#now add current dir (if no conflict with above)
-set currentdir_modules [glob -nocomplain -dir [pwd] -type f -tail *.tm]
-set tcl_core_packages [list tcl::zlib zlib tcl::oo TclOO tcl::tommath tcl::zipfs Tcl Tk]
-if {[llength $currentdir_modules]} {
-    #only forget all *unloaded* package names if we are started in a .tm containing folder
-    foreach pkg [package names] {
-        if {$pkg in $tcl_core_packages} {
-            continue
-        }
-        if {![llength [package versions $pkg]]} {
-            #puts stderr "Got no versions for pkg $pkg"
-            continue
-        }
-        if {![string length [package provide $pkg]]} {
-            puts stderr "--->package forget $pkg<---"
-            package forget $pkg
-        }
-    }
-    catch {tcl::tm::add [pwd]}
-}
-
-#These are strong dependencies 
-# - the repl requires Threading and shellfilter to call and display properly.
-# tm list already indexed - 'package forget' to find modules based on current tcl::tm::list
-#set required [list\
-#    shellfilter\
-#    shellrun\
-#    punk\
-#    ]
-
-#punk & shellrun should be in codethreads - but not required in the parent repl threads
-
-set required [list\
-    shellfilter\
-    ]
-
-catch {
-    foreach pkg $required {
-        package forget $pkg
-        package require $pkg
-    }
-}
-
-
-#restore module paths 
-set tm_list_now [tcl::tm::list]
-foreach p $original_tm_list {
-    if {$p ni $tm_list_now} {
-        #the prior tm paths go to the head of the list.
-        #They are processed first.. but an item of same version later in the list will override one at the head. (depending on when list was scanned)
-        tcl::tm::add $p
-    }
-}
-#------------------------------------------------------------------------------
-#now we need to package require a bogus package to ensure Tcl scans the whole auto_path/tm list - otherwise a lower-versioned module earlier in the path may be loaded
-#This seems to take not insignificant time depending on size of auto_path and tcl::tm::list (e.g 2023 i9 100ms) - but seems unavoidable for now
-catch {package require flobrudder666_nonexistant}
-#------------------------------------------------------------------------------
-
-#puts stdout "$::auto_path"
-#puts stderr "-----------"
-#puts stderr "tcl::tm::list"
-#puts stderr "-----------"
-#puts stderr "[join [tcl::tm::list] \n]"
-#puts stderr "-----------"
-#puts stderr "auto_path"
-#puts stderr "-----------"
-#puts stderr "[join $::auto_path \n]"
-#puts stderr "-----------"
-#puts stderr "thread? [package provide Thread]"
-set thread_version [package require Thread]
-#puts stderr "repl.tcl thread version:$thread_version"
-catch {package require tcllibc}
-foreach pkg $required {
-    package require $pkg
-}
-
-package require punk::repl
-repl::init -safe 0
-repl::start stdin -title app-punk
-
-
-

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

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/LICENSE

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/adsi.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/apputil.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/clipboard.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/console.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/device.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/eventlog.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/evt.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/handle.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/input.tcl

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

src/vfs/punk86old.vfs/lib_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/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/msi.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/mstask.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/multimedia.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/namedpipe.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/nls.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/pdh.tcl

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

src/vfs/punk86old.vfs/lib_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/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/power.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/printer.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/rds.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/registry.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/resource.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/share.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/shell.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/sspi.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/storage.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/synch.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/twapi.tcl

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

src/vfs/punk86old.vfs/lib_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/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/win.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/winlog.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/winsta.tcl

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

src/vfs/punk86old.vfs/lib_tcl8/twapi4.7.2/wmi.tcl

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

src/vfs/punk86old.vfs/main.tcl

@@ -1,24 +0,0 @@
-
-if {[catch {package require starkit}]} {
-    #presumably running the xxx.vfs/main.tcl script using a non-starkit tclsh that doesn't have starkit lib available.. lets see if we can move forward anyway
-    lappend ::auto_path [file join [file dirname [info script]] lib]
-} else {
-    starkit::startup
-}
-
-#when run as a tclkit - the exe is mounted as a dir and Tcl's auto_execok doesn't find it
-set thisexe [file tail [info nameofexecutable]]
-set thisexeroot [file rootname $thisexe]
-set ::auto_execs($thisexeroot) [info nameofexecutable]
-if {$thisexe ne $thisexeroot} {
-    set ::auto_execs($thisexe) [info nameofexecutable]
-}
-if {[llength $::argv]} {
-    package require app-shellspy
-} else {
-    package require app-punk
-
-    #app-punk starts repl
-    #repl::start stdin -title "main.tcl"
-}
-

src/vfs/punk86old.vfs/modules/testmodule-1.0.tm

@@ -1,27 +0,0 @@
-apply {code {
-    puts stdout "--script dir:[file dirname [file normalize [info script]]]--"
-    
-    set mypath [file dirname [file normalize [info script]]]
-    set mysegs [file split $mypath]
-    set overhang [list]
-    foreach libpath [tcl::tm::list] {
-        set libsegs [file split $libpath] ;#we split and rejoin with '/' because sometimes module paths may be specified with mixed \ & / on a single machine, or even within a single path.
-        if {[file join $mysegs /] eq [file join [lrange $libsegs 0 [llength $mysegs]] /]} {
-            #mypath is below libpath
-            set overhang [lrange $mysegs [llength $libsegs]+1  end]    
-            break
-        }
-    }
-    
-    set modver [file root [file tail [info script]]]
-    lassign [split $modver -] nsfinal version
-    set ns [join [concat $overhang $nsfinal] ::]
-    
-    package provide $ns [namespace eval $ns "$code\n set version $version"]
- } ::} {
-    # Module procs here, where current namespace is that of the module.
-    # Package version can, if needed, be accessed as [uplevel 1 {set version}]
-    proc spud {} {
-        puts "spuds!"
-    }
- }