QuickWho

package ifneeded tdom 0.8.3  "load [list [file join $dir tdom083.dll]]; source [list [file join $dir tdom.tcl]]"

#----------------------------------------------------------------------------
#   Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com)
#----------------------------------------------------------------------------
#
#   $Id$
#
#
#   The higher level functions of tDOM written in plain Tcl.
#
#
#   The contents of this file are subject to the Mozilla Public License
#   Version 1.1 (the "License"); you may not use this file except in
#   compliance with the License. You may obtain a copy of the License at
#   http://www.mozilla.org/MPL/
#
#   Software distributed under the License is distributed on an "AS IS"
#   basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
#   License for the specific language governing rights and limitations
#   under the License.
#
#   The Original Code is tDOM.
#
#   The Initial Developer of the Original Code is Jochen Loewer
#   Portions created by Jochen Loewer are Copyright (C) 1998, 1999
#   Jochen Loewer. All Rights Reserved.
#
#   Contributor(s):
#       Rolf Ade (rolf@pointsman.de):   'fake' nodelists/live childNodes
#
#   written by Jochen Loewer
#   April, 1999
#
#----------------------------------------------------------------------------

package require tdom 

#----------------------------------------------------------------------------
#   setup namespaces for additional Tcl level methods, etc.
#
#----------------------------------------------------------------------------
namespace eval ::dom {
    namespace eval  domDoc {
    }
    namespace eval  domNode {
    }
    namespace eval  DOMImplementation {
    }
    namespace eval  xpathFunc {
    }
    namespace eval  xpathFuncHelper {
    }
}

namespace eval ::tDOM { 
    variable extRefHandlerDebug 0
    variable useForeignDTD ""

    namespace export xmlOpenFile xmlReadFile extRefHandler baseURL
}

#----------------------------------------------------------------------------
#   hasFeature (DOMImplementation method)
#
#
#   @in  url    the URL, where to get the XML document
#
#   @return     document object
#   @exception  XML parse errors, ...
#
#----------------------------------------------------------------------------
proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } {

    switch $feature {
        xml -
        XML {
            if {($version == "") || ($version == "1.0")} {
                return 1
            }
        }
    }
    return 0

}

#----------------------------------------------------------------------------
#   load (DOMImplementation method)
#
#       requests a XML document via http using the given URL and
#       builds up a DOM tree in memory returning the document object
#
#
#   @in  url    the URL, where to get the XML document
#
#   @return     document object
#   @exception  XML parse errors, ...
#
#----------------------------------------------------------------------------
proc ::dom::DOMImplementation::load { dom url } {

    error "Sorry, load method not implemented yet!"

}

#----------------------------------------------------------------------------
#   isa (docDoc method, for [incr tcl] compatibility)
#
#
#   @in  className
#
#   @return         1 iff inherits from the given class
#
#----------------------------------------------------------------------------
proc ::dom::domDoc::isa { doc className } {

    if {$className == "domDoc"} {
        return 1
    }
    return 0
}

#----------------------------------------------------------------------------
#   info (domDoc method, for [incr tcl] compatibility)
#
#
#   @in  subcommand
#   @in  args
#
#----------------------------------------------------------------------------
proc ::dom::domDoc::info { doc subcommand args } {

    switch $subcommand {
        class {
            return "domDoc"
        }
        inherit {
            return ""
        }
        heritage {
            return "domDoc {}"
        }
        default {
            error "domDoc::info subcommand $subcommand not yet implemented!"
        }
    }
}

#----------------------------------------------------------------------------
#   importNode (domDoc method)
#
#       Document Object Model (Core) Level 2 method
#
#
#   @in  subcommand
#   @in  args
#
#----------------------------------------------------------------------------
proc ::dom::domDoc::importNode { doc importedNode deep } {

    if {$deep || ($deep == "-deep")} {
        set node [$importedNode cloneNode -deep]
    } else {
        set node [$importedNode cloneNode]
    }
    return $node
}

#----------------------------------------------------------------------------
#   isa (domNode method, for [incr tcl] compatibility)
#
#
#   @in  className
#
#   @return         1 iff inherits from the given class
#
#----------------------------------------------------------------------------
proc ::dom::domNode::isa { doc className } {

    if {$className == "domNode"} {
        return 1
    }
    return 0
}

#----------------------------------------------------------------------------
#   info (domNode method, for [incr tcl] compatibility)
#
#
#   @in  subcommand
#   @in  args
#
#----------------------------------------------------------------------------
proc ::dom::domNode::info { doc subcommand args } {

    switch $subcommand {
        class {
            return "domNode"
        }
        inherit {
            return ""
        }
        heritage {
            return "domNode {}"
        }
        default {
            error "domNode::info subcommand $subcommand not yet implemented!"
        }
    }
}

#----------------------------------------------------------------------------
#   isWithin (domNode method)
#
#       tests, whether a node object is nested below another tag
#
#
#   @in  tagName  the nodeName of an elment node
#
#   @return       1 iff node is nested below a element with nodeName tagName
#                 0 otherwise
#
#----------------------------------------------------------------------------
proc ::dom::domNode::isWithin { node tagName } {

    while {[$node parentNode] != ""} {
        set node [$node parentNode]
        if {[$node nodeName] == $tagName} {
            return 1
        }
    }
    return 0
}

#----------------------------------------------------------------------------
#   tagName (domNode method)
#
#       same a nodeName for element interface
#
#----------------------------------------------------------------------------
proc ::dom::domNode::tagName { node } {

    if {[$node nodeType] == "ELEMENT_NODE"} {
        return [$node nodeName]
    }
    return -code error "NOT_SUPPORTED_ERR not an element!"
}

#----------------------------------------------------------------------------
#   simpleTranslate (domNode method)
#
#       applies simple translation rules similar to Cost's simple
#       translations to a node
#
#
#   @in  output_var
#   @in  trans_specs
#
#----------------------------------------------------------------------------
proc ::dom::domNode::simpleTranslate { node output_var trans_specs } {

    upvar $output_var output

    if {[$node nodeType] == "TEXT_NODE"} {
        append output [cgiQuote [$node nodeValue]]
        return
    }
    set found 0

    foreach {match action} $trans_specs {

        if {[catch {
            if {!$found && ([$node selectNode self::$match] != "") } {
              set found 1
            }
        } err]} {
            if {![string match "NodeSet expected for parent axis!" $err]} {
                error $err
            }
        }
        if {$found && ($action != "-")} {
            set stop 0
            foreach {type value} $action {
                switch $type {
                    prefix { append output [subst $value] }
                    tag    { append output <$value>       }
                    start  { append output [eval $value]  }
                    stop   { set stop 1                   }
                }
            }
            if {!$stop} {
                foreach child [$node childNodes] {
                    simpleTranslate  $child output $trans_specs
                }
            }
            foreach {type value} $action {
                switch $type {
                    suffix { append output [subst $value] }
                    end    { append output [eval $value]  }
                    tag    { append output </$value>      }
                }
            }
            return
        }
    }
    foreach child [$node childNodes] {
        simpleTranslate $child output $trans_specs
    }
}

#----------------------------------------------------------------------------
#   a DOM conformant 'live' childNodes
#
#   @return   a 'nodelist' object (it is just the normal node)
#
#----------------------------------------------------------------------------
proc ::dom::domNode::childNodesLive { node } {

    return $node
}

#----------------------------------------------------------------------------
#   item method on a 'nodelist' object
#
#   @return   a 'nodelist' object (it is just a normal
#
#----------------------------------------------------------------------------
proc ::dom::domNode::item { nodeListNode index } {

    return [lindex [$nodeListNode childNodes] $index]
}

#----------------------------------------------------------------------------
#   length method on a 'nodelist' object
#
#   @return   a 'nodelist' object (it is just a normal
#
#----------------------------------------------------------------------------
proc ::dom::domNode::length { nodeListNode } {

    return [llength [$nodeListNode childNodes]]
}

#----------------------------------------------------------------------------
#   appendData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::appendData { node  arg } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    set oldValue [$node nodeValue]
    $node nodeValue [append oldValue $arg]
}

#----------------------------------------------------------------------------
#   deleteData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::deleteData { node offset count } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    incr offset -1
    set before [string range [$node nodeValue] 0 $offset]
    incr offset
    incr offset $count
    set after  [string range [$node nodeValue] $offset end]
    $node nodeValue [append before $after]
}

#----------------------------------------------------------------------------
#   insertData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::insertData { node  offset arg } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    incr offset -1
    set before [string range [$node nodeValue] 0 $offset]
    incr offset
    set after  [string range [$node nodeValue] $offset end]
    $node nodeValue [append before $arg $after]
}

#----------------------------------------------------------------------------
#   replaceData on a 'CharacterData' object
#
#----------------------------------------------------------------------------
proc ::dom::domNode::replaceData { node offset count arg } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    incr offset -1
    set before [string range [$node nodeValue] 0 $offset]
    incr offset
    incr offset $count
    set after  [string range [$node nodeValue] $offset end]
    $node nodeValue [append before $arg $after]
}

#----------------------------------------------------------------------------
#   substringData on a 'CharacterData' object
#
#   @return   part of the node value (text)
#
#----------------------------------------------------------------------------
proc ::dom::domNode::substringData { node offset count } {

    set type [$node nodeType]
    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
        ($type != "COMMENT_NODE")
    } {
        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
    }
    set endOffset [expr $offset + $count - 1]
    return [string range [$node nodeValue] $offset $endOffset]
}

#----------------------------------------------------------------------------
#   coerce2number
#
#----------------------------------------------------------------------------
proc ::dom::xpathFuncHelper::coerce2number { type value } {
    switch $type {
        empty      { return 0 }
        number -
        string     { return $value }
        attrvalues { return [lindex $value 0] }
        nodes      { return [[lindex $value 0] selectNodes number()] }
        attrnodes  { return [lindex $value 1] }
    }
}

#----------------------------------------------------------------------------
#   coerce2string
#
#----------------------------------------------------------------------------
proc ::dom::xpathFuncHelper::coerce2string { type value } {
    switch $type {
        empty      { return "" }
        number -
        string     { return $value }
        attrvalues { return [lindex $value 0] }
        nodes      { return [[lindex $value 0] selectNodes string()] }
        attrnodes  { return [lindex $value 1] }
    }
}

#----------------------------------------------------------------------------
#   function-available
#
#----------------------------------------------------------------------------
proc ::dom::xpathFunc::function-available { ctxNode pos
                                            nodeListType nodeList args} {

    if {[llength $args] != 2} {
        error "function-available(): wrong # of args!"
    }
    foreach { arg1Typ arg1Value } $args break
    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
    switch $str {
        boolean -
        ceiling -
        concat -
        contains -
        count -
        current -
        document -
        element-available -
        false -
        floor -
        format-number -
        generate-id -
        id -
        key -
        last -
        lang -
        local-name -
        name -
        namespace-uri -
        normalize-space -
        not -
        number -
        position -
        round -
        starts-with -
        string -
        string-length -
        substring -
        substring-after -
        substring-before -
        sum -
        translate -
        true -
        unparsed-entity-uri {
            return [list bool true]
        }
        default {
            set TclXpathFuncs [info procs ::dom::xpathFunc::*]
            if {[lsearch -exact $TclXpathFuncs $str] != -1} {
                return [list bool true]
            } else {
                return [list bool false]
            }
        }
    }
}

#----------------------------------------------------------------------------
#   element-available
#
#   This is not strictly correct. The XSLT namespace may be bound
#   to another prefix (and the prefix 'xsl' may be bound to another
#   namespace). Since the expression context isn't available at the
#   moment at tcl coded XPath functions, this couldn't be done better
#   than this "works in the 'normal' cases" version.
#----------------------------------------------------------------------------
proc ::dom::xpathFunc::element-available { ctxNode pos
                                            nodeListType nodeList args} {

    if {[llength $args] != 2} {
        error "element-available(): wrong # of args!"
    }
    foreach { arg1Typ arg1Value } $args break
    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
    # The XSLT recommendation says: "The element-available
    # function returns true if and only if the expanded-name
    # is the name of an instruction." The following xsl
    # elements are not in the category instruction.
    # xsl:attribute-set 
    # xsl:decimal-format 
    # xsl:include
    # xsl:key 
    # xsl:namespace-alias
    # xsl:output
    # xsl:param
    # xsl:strip-space
    # xsl:preserve-space
    # xsl:template
    # xsl:import
    # xsl:otherwise
    # xsl:sort
    # xsl:stylesheet
    # xsl:transform
    # xsl:with-param
    # xsl:when
    switch $str {
        xsl:apply-templates -
        xsl:apply-imports -
        xsl:call-template -
        xsl:element -
        xsl:attribute -
        xsl:text -
        xsl:processing-instruction -
        xsl:comment -
        xsl:copy -
        xsl:value-of -
        xsl:number -
        xsl:for-each -
        xsl:if -
        xsl:choose -
        xsl:variable -
        xsl:copy-of -
        xsl:message -
        xsl:fallback {
            return [list bool true]
        }
        default {
            return [list bool false]
        }
    }
}

#----------------------------------------------------------------------------
#   system-property
#
#   This is not strictly correct. The XSLT namespace may be bound
#   to another prefix (and the prefix 'xsl' may be bound to another
#   namespace). Since the expression context isn't available at the
#   moment at tcl coded XPath functions, this couldn't be done better
#   than this "works in the 'normal' cases" version.
#----------------------------------------------------------------------------
proc ::dom::xpathFunc::system-property { ctxNode pos
                                         nodeListType nodeList args } {

    if {[llength $args] != 2} {
        error "system-property(): wrong # of args!"
    }
    foreach { arg1Typ arg1Value } $args break
    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
    switch $str {
        xsl:version {
            return [list number 1.0]
        }
        xsl:vendor {
            return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."]
        }
        xsl:vendor-url {
            return [list string "http://www.tdom.org"]
        }
        default {
            return [list string ""]
        }
    }
}

#----------------------------------------------------------------------------
#   IANAEncoding2TclEncoding
#
#----------------------------------------------------------------------------

# As of version 8.3.4 tcl supports 
# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949
# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201
# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp
# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737
# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr
# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic
# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6
# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253
# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852
# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode
# cp857
# 
# Just add more mappings (and mail them to the tDOM mailing list, please).

proc tDOM::IANAEncoding2TclEncoding {IANAName} {
    
    # First the most widespread encodings with there
    # preferred MIME name, to speed lookup in this
    # usual cases. Later the official names and the
    # aliases.
    #
    # For "official names for character sets that may be
    # used in the Internet" see 
    # http://www.iana.org/assignments/character-sets
    # (that's the source for the encoding names below)
    # 
    # Matching is case-insensitive

    switch [string tolower $IANAName] {
        "us-ascii"    {return ascii}
        "utf-8"       {return utf-8}
        "utf-16"      {return unicode; # not sure about this}
        "iso-8859-1"  {return iso8859-1}
        "iso-8859-2"  {return iso8859-2}
        "iso-8859-3"  {return iso8859-3}
        "iso-8859-4"  {return iso8859-4}
        "iso-8859-5"  {return iso8859-5}
        "iso-8859-6"  {return iso8859-6}
        "iso-8859-7"  {return iso8859-7}
        "iso-8859-8"  {return iso8859-8}
        "iso-8859-9"  {return iso8859-9}
        "iso-8859-10" {return iso8859-10}
        "iso-8859-13" {return iso8859-13}
        "iso-8859-14" {return iso8859-14}
        "iso-8859-15" {return iso8859-15}
        "iso-8859-16" {return iso8859-16}
        "iso-2022-kr" {return iso2022-kr}
        "euc-kr"      {return euc-kr}
        "iso-2022-jp" {return iso2022-jp}
        "koi8-r"      {return koi8-r}
        "shift_jis"   {return shiftjis}
        "euc-jp"      {return euc-jp}
        "gb2312"      {return gb2312}
        "big5"        {return big5}
        "cp866"       {return cp866}
        "cp1250"      {return cp1250}
        "cp1253"      {return cp1253}
        "cp1254"      {return cp1254}
        "cp1255"      {return cp1255}
        "cp1256"      {return cp1256}
        "cp1257"      {return cp1257}

        "windows-1251" -
        "cp1251"      {return cp1251}

        "windows-1252" -
        "cp1252"      {return cp1252}    

        "iso_8859-1:1987" -
        "iso-ir-100" -
        "iso_8859-1" -
        "latin1" -
        "l1" -
        "ibm819" -
        "cp819" -
        "csisolatin1" {return iso8859-1}
        
        "iso_8859-2:1987" -
        "iso-ir-101" -
        "iso_8859-2" -
        "iso-8859-2" -
        "latin2" -
        "l2" -
        "csisolatin2" {return iso8859-2}

        "iso_8859-5:1988" -
        "iso-ir-144" -
        "iso_8859-5" -
        "iso-8859-5" -
        "cyrillic" -
        "csisolatincyrillic" {return iso8859-5}

        "ms_kanji" -
        "csshiftjis"  {return shiftjis}
        
        "csiso2022kr" {return iso2022-kr}

        "ibm866" -
        "csibm866"    {return cp866}
        
        default {
            # There are much more encoding names out there
            # It's only laziness, that let me stop here.
            error "Unrecognized encoding name '$IANAName'"
        }
    }
}

#----------------------------------------------------------------------------
#   xmlOpenFile
#
#----------------------------------------------------------------------------
proc tDOM::xmlOpenFile {filename {encodingString {}}} {

    set fd [open $filename]

    if {$encodingString != {}} {
        upvar $encodingString encString
    }

    # The autodetection of the encoding follows
    # XML Recomendation, Appendix F

    fconfigure $fd -encoding binary
    if {![binary scan [read $fd 4] "H8" firstBytes]} {
        # very short (< 4 Bytes) file
        seek $fd 0 start
        set encString UTF-8
        return $fd
    }
    
    # First check for BOM
    switch [string range $firstBytes 0 3] {
        "feff" -
        "fffe" {
            # feff: UTF-16, big-endian BOM
            # ffef: UTF-16, little-endian BOM
            seek $fd 0 start
            set encString UTF-16            
            fconfigure $fd -encoding identity
            return $fd
        }
    }

    # If the entity has a XML Declaration, the first four characters
    # must be "<?xm".
    switch $firstBytes {
        "3c3f786d" {
            # UTF-8, ISO 646, ASCII, some part of ISO 8859, Shift-JIS,
            # EUC, or any other 7-bit, 8-bit, or mixed-width encoding which 
            # ensures that the characters of ASCII have their normal positions,
            # width and values; the actual encoding declaration must be read to
            # detect which of these applies, but since all of these encodings
            # use the same bit patterns for the ASCII characters, the encoding
            # declaration itself be read reliably.

            # First 300 bytes should be enough for a XML Declaration
            # This is of course not 100 percent bullet-proof.
            set head [read $fd 296]

            # Try to find the end of the XML Declaration
            set closeIndex [string first ">" $head]
            if {$closeIndex == -1} {
                error "Weird XML data or not XML data at all"
            }

            seek $fd 0 start
            set xmlDeclaration [read $fd [expr {$closeIndex + 5}]]
            # extract the encoding information
            set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]}
            # emacs: "
            if {![regexp $pattern $head - encStr]} {
                # Probably something like <?xml version="1.0"?>. 
                # Without encoding declaration this must be UTF-8
                set encoding utf-8
                set encString UTF-8
            } else {
                set encoding [IANAEncoding2TclEncoding $encStr]
                set encString $encStr
            }
        }
        "0000003c" -
        "0000003c" -
        "3c000000" -
        "00003c00" {
            # UCS-4
            error "UCS-4 not supported"
        }
        "003c003f" -
        "3c003f00" {
            # UTF-16, big-endian, no BOM
            # UTF-16, little-endian, no BOM
            seek $fd 0 start
            set encoding identity
            set encString UTF-16
        }
        "4c6fa794" {
            # EBCDIC in some flavor
            error "EBCDIC not supported"
        }
        default {
            # UTF-8 without an encoding declaration
            seek $fd 0 start
            set encoding identity
            set encString "UTF-8"
        }
    }
    fconfigure $fd -encoding $encoding
    return $fd
}

#----------------------------------------------------------------------------
#   xmlReadFile
#
#----------------------------------------------------------------------------
proc tDOM::xmlReadFile {filename {encodingString {}}} {

    if {$encodingString != {}} {
        upvar $encodingString encString
    }
    
    set fd [xmlOpenFile $filename encString]
    set data [read $fd [file size $filename]]
    close $fd 
    return $data
}

#----------------------------------------------------------------------------
#   extRefHandler
#   
#   A very simple external entity resolver, included for convenience.
#   Depends on the tcllib package uri and resolves only file URLs. 
#
#----------------------------------------------------------------------------

if {![catch {package require uri}]} {
    proc tDOM::extRefHandler {base systemId publicId} {
        variable extRefHandlerDebug
        variable useForeignDTD

        if {$extRefHandlerDebug} {
            puts stderr "tDOM::extRefHandler called with:"
            puts stderr "\tbase:     '$base'"
            puts stderr "\tsystemId: '$systemId'"
            puts stderr "\tpublicId: '$publicId'"
        }
        if {$systemId == ""} {
            if {$useForeignDTD != ""} {
                set systemId $useForeignDTD
            } else {
                error "::tDOM::useForeignDTD does\
                        not point to the foreign DTD"
            }
        }
        set absolutURI [uri::resolve $base $systemId]
        array set uriData [uri::split $absolutURI]
        switch $uriData(scheme) {
            file {
                return [list string $absolutURI [xmlReadFile $uriData(path)]]
            }
            default {
                error "can only handle file URI's"
            }
        }
    }
}

#----------------------------------------------------------------------------
#   baseURL
#   
#   A simple convenience proc which returns an absolute URL for a given
#   filename.
#
#----------------------------------------------------------------------------

proc tDOM::baseURL {path} {
    switch [file pathtype $path] {
        "relative" {
            return "file://[pwd]/$path"
        }
        default {
            return "file://$path"
        }
    }
}

# EOF

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.

# Tcl Windows API (TWAPI) 4.1

This is the release version of TWAPI 4.1.

  * Project home page is at http://twapi.sourceforge.net
  * V4.1 documentation is at http://twapi.sourceforge.net/v4.1

## Supported platforms

TWAPI 4.1 requires

  * Windows XP (32-bit only) or later (32- or 64- bit)
  * Tcl 8.5 or 8.6 (32- or 64-bit)

## Changes since 4.0

Major changes in this release are support for writing COM servers
and other COM enhancements, STARTTLS support for TLS sockets,
and additional functionality in the security, services,
device management and console modules.

For a complete list, including INCOMPATIBLE CHANGES, see 
http://twapi.sourceforge.net/v4.1/versionhistory.html

## Distributions

TWAPI is distributed in multiple formats.
See http://twapi.sourceforge.net/v4.1/installation.html for the details
and the pros and cons of each format.

## TWAPI Summary

The Tcl Windows API (TWAPI) extension provides
access to over 600 functions in the Windows API
from within the Tcl scripting language.

Functions in the following areas are implemented:

  * System functions including OS and CPU information,
    shutdown and message formatting
  * User and group management
  * COM client and server support
  * Security and resource access control
  * Window management
  * User input: generate key/mouse input and hotkeys
  * Basic sound playback functions
  * Windows services
  * Windows event log access
  * Windows event tracing
  * Process and thread management
  * Directory change monitoring
  * Lan Manager and file and print shares
  * Drive information, file system types etc.
  * Network configuration and statistics
  * Network connection monitoring and control
  * Named pipes
  * Clipboard access
  * Taskbar icons and notifications
  * Console mode functions
  * Window stations and desktops
  * Internationalization
  * Task scheduling
  * Shell functions 
  * Windows Installer
  * Synchronization
  * Power management
  * Device I/O and management
  * Crypto API and certificates
  * SSL/TLS
  * Windows Performance Counters

#
# Copyright (c) 2009-2015, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

package require twapi_security

namespace eval twapi {
    record USER_INFO_0 {-name}
    record USER_INFO_1 [concat [USER_INFO_0] {
        -password -password_age -priv -home_dir -comment -flags -script_path
    }]
    record USER_INFO_2 [concat [USER_INFO_1] {
        -auth_flags -full_name -usr_comment -parms 
        -workstations -last_logon -last_logoff -acct_expires -max_storage
        -units_per_week -logon_hours -bad_pw_count -num_logons
        -logon_server -country_code -code_page
    }]
    record USER_INFO_3 [concat [USER_INFO_2] {
        -user_id -primary_group_id -profile -home_dir_drive -password_expired
    }]
    record USER_INFO_4 [concat [USER_INFO_2] {
        -sid -primary_group_id -profile -home_dir_drive -password_expired
    }]

    record GROUP_INFO_0 {-name}
    record GROUP_INFO_1 {-name -comment}
    record GROUP_INFO_2 {-name -comment -group_id -attributes}
    record GROUP_INFO_3 {-name -comment -sid -attributes}

    record NetEnumResult {moredata hresume totalentries entries}

}

# Add a new user account
proc twapi::new_user {username args} {
    array set opts [parseargs args [list \
                                        system.arg \
                                        password.arg \
                                        comment.arg \
                                        [list priv.arg "user" [array names twapi::priv_level_map]] \
                                        home_dir.arg \
                                        script_path.arg \
                                       ] \
                        -nulldefault]

    if {$opts(priv) ne "user"} {
        error "Option -priv is deprecated and values other than 'user' are not allowed"
    }

    # 1 -> priv level 'user'. NetUserAdd mandates this as only allowed value
    NetUserAdd $opts(system) $username $opts(password) 1 \
        $opts(home_dir) $opts(comment) 0 $opts(script_path)


    # Backward compatibility - add to 'Users' local group
    # but only if -system is local
    if {$opts(system) eq "" ||
        ([info exists ::env(COMPUTERNAME)] &&
         [string equal -nocase $opts(system) $::env(COMPUTERNAME)])} {
        trap {
            _set_user_priv_level $username $opts(priv) -system $opts(system)
        } onerror {} {
            # Remove the previously created user account
            catch {delete_user $username -system $opts(system)}
            rethrow
        }
    }
}


# Delete a user account
proc twapi::delete_user {username args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    # Remove the user from the LSA rights database.
    _delete_rights $username $opts(system)

    NetUserDel $opts(system) $username
}


# Define various functions to set various user account fields
foreach twapi::_field_ {
    {name  0}
    {password  1003}
    {home_dir  1006}
    {comment  1007}
    {script_path  1009}
    {full_name  1011}
    {country_code  1024}
    {profile  1052}
    {home_dir_drive  1053}
} {
    proc twapi::set_user_[lindex $::twapi::_field_ 0] {username fieldval args} "
        array set opts \[parseargs args {
            system.arg
        } -nulldefault \]
        Twapi_NetUserSetInfo [lindex $::twapi::_field_ 1] \$opts(system) \$username \$fieldval"
}
unset twapi::_field_

# Set account expiry time
proc twapi::set_user_expiration {username time args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    if {![string is integer -strict $time]} {
        if {[string equal $time "never"]} {
            set time -1
        } else {
            set time [clock scan $time]
        }
    }
    Twapi_NetUserSetInfo 1017 $opts(system) $username $time
}

# Unlock a user account
proc twapi::unlock_user {username args} {
    # UF_LOCKOUT -> 0x10
    _change_user_info_flags $username 0x10 0 {*}$args
}

# Enable a user account
proc twapi::enable_user {username args} {
    # UF_ACCOUNTDISABLE -> 0x2
    _change_user_info_flags $username 0x2 0 {*}$args
}

# Disable a user account
proc twapi::disable_user {username args} {
    # UF_ACCOUNTDISABLE -> 0x2
    _change_user_info_flags $username 0x2 0x2 {*}$args
}


# Return the specified fields for a user account
proc twapi::get_user_account_info {account args} {
    # Define each option, the corresponding field, and the 
    # information level at which it is returned
    array set fields {
        comment 1
        password_expired 4
        full_name 2
        parms 2
        units_per_week 2
        primary_group_id 4
        flags 1
        logon_server 2
        country_code 2
        home_dir 1
        password_age 1
        home_dir_drive 4
        num_logons 2
        acct_expires 2
        last_logon 2
        usr_comment 2
        bad_pw_count 2
        code_page 2
        logon_hours 2
        workstations 2
        last_logoff 2
        name 0
        script_path 1
        profile 4
        max_storage 2
    }
    # Left out - auth_flags 2
    # Left out (always returned as NULL) - password {usri3_password 1}
    # Note sid is available at level 4 as well but don't want to set
    # level 4 just for that since we can get it by other means. Hence
    # not listed above

    array set opts [parseargs args \
                        [concat [array names fields] sid \
                             internet_identity \
                             status type password_attrs \
                             [list local_groups global_groups system.arg all]] \
                        -nulldefault]

    if {$opts(all)} {
        set level 4
        set opts(local_groups) 1
        set opts(global_groups) 1
    } else {
        # Based on specified fields, figure out what level info to ask for
        set level -1
        foreach {opt optval} [array get opts] {
            if {[info exists fields($opt)] &&
                $optval &&
                $fields($opt) > $level
            } {
                set level $fields($opt)
            }
        }                
        if {$opts(status) || $opts(type) || $opts(password_attrs)} {
            # These fields are based on the flags field
            if {$level < 1} {
                set level 1
            }
        }
    }
    
    array set result [list ]

    if {$level > -1} {
        set rawdata [NetUserGetInfo $opts(system) $account $level]
        array set data [USER_INFO_$level $rawdata]

        # Extract the requested data
        foreach opt [array names fields] {
            if {$opts(all) || $opts($opt)} {
                set result(-$opt) $data(-$opt)
            }
        }
        if {$level == 4 && ($opts(all) || $opts(sid))} {
            set result(-sid) $data(-sid)
        }

        # Map internal values to more friendly formats
        if {$opts(all) || $opts(status) || $opts(type) || $opts(password_attrs)} {
            array set result [_map_userinfo_flags $data(-flags)]
            if {! $opts(all)} {
                if {! $opts(status)} {unset result(-status)}
                if {! $opts(type)} {unset result(-type)}
                if {! $opts(password_attrs)} {unset result(-password_attrs)}
            }
        }

        if {[info exists result(-logon_hours)]} {
            binary scan $result(-logon_hours) b* result(-logon_hours)
        }

        foreach time_field {-acct_expires -last_logon -last_logoff} {
            if {[info exists result($time_field)]} {
                if {$result($time_field) == -1 || $result($time_field) == 4294967295} {
                    set result($time_field) "never"
                } elseif {$result($time_field) == 0} {
                    set result($time_field) "unknown"
                }
            }
        }
    }

    if {$opts(all) || $opts(internet_identity)} {
        set result(-internet_identity) {}
        if {[min_os_version 6 2]} {
            set inet_ident [NetUserGetInfo $opts(system) $account 24]
            if {[llength $inet_ident]} {
                set result(-internet_identity) [twine {
                    internet_provider_name internet_principal_name sid
                } [lrange $inet_ident 1 end]]
            }
        }
    }

    # The Net* calls always return structures as lists even when the struct
    # contains only one field so we need to lpick to extract the field

    if {$opts(local_groups)} {
        set result(-local_groups) [lpick [NetEnumResult entries [NetUserGetLocalGroups $opts(system) $account 0 0]] 0]
    }

    if {$opts(global_groups)} {
        set result(-global_groups) [lpick [NetEnumResult entries [NetUserGetGroups $opts(system) $account 0]] 0]
    }

    if {$opts(sid)  && ! [info exists result(-sid)]} {
        set result(-sid) [lookup_account_name $account -system $opts(system)]
    }

    return [array get result]
}

proc twapi::get_user_global_groups {account args} {
    parseargs args {
        system.arg
        denyonly
        all
    } -nulldefault -maxleftover 0 -setvars

    set groups {}
    foreach elem [NetEnumResult entries [NetUserGetGroups $system [map_account_to_name $account -system $system] 1]] {
        # 0x10 -> SE_GROUP_USE_FOR_DENY_ONLY
        set marked_denyonly [expr {[lindex $elem 1] & 0x10}]
        if {$all || ($denyonly && $marked_denyonly) || !($denyonly || $marked_denyonly)} {
            lappend groups [lindex $elem 0]
        }
    }
    return $groups
}

proc twapi::get_user_local_groups {account args} {
    parseargs args {
        system.arg
        {recurse.bool 0}
    } -nulldefault -maxleftover 0 -setvars

    # The Net* calls always return structures as lists even when the struct
    # contains only one field so we need to lpick to extract the field
    return [lpick [NetEnumResult entries [NetUserGetLocalGroups $system [map_account_to_name $account -system $system] 0 $recurse]] 0]
}

proc twapi::get_user_local_groups_recursive {account args} {
    return [get_user_local_groups $account {*}$args -recurse 1]
}


# Set the specified fields for a user account
proc twapi::set_user_account_info {account args} {

    # Define each option, the corresponding field, and the 
    # information level at which it is returned
    array set opts [parseargs args {
        {system.arg ""}
        comment.arg
        full_name.arg
        country_code.arg
        home_dir.arg
        home_dir.arg
        acct_expires.arg
        name.arg
        script_path.arg
        profile.arg
    }]

    # TBD - rewrite this to be atomic

    if {[info exists opts(comment)]} {
        set_user_comment $account $opts(comment) -system $opts(system)
    }

    if {[info exists opts(full_name)]} {
        set_user_full_name $account $opts(full_name) -system $opts(system)
    }

    if {[info exists opts(country_code)]} {
        set_user_country_code $account $opts(country_code) -system $opts(system)
    }

    if {[info exists opts(home_dir)]} {
        set_user_home_dir $account $opts(home_dir) -system $opts(system)
    }

    if {[info exists opts(home_dir_drive)]} {
        set_user_home_dir_drive $account $opts(home_dir_drive) -system $opts(system)
    }

    if {[info exists opts(acct_expires)]} {
        set_user_expiration $account $opts(acct_expires) -system $opts(system)
    }

    if {[info exists opts(name)]} {
        set_user_name $account $opts(name) -system $opts(system)
    }

    if {[info exists opts(script_path)]} {
        set_user_script_path $account $opts(script_path) -system $opts(system)
    }

    if {[info exists opts(profile)]} {
        set_user_profile $account $opts(profile) -system $opts(system)
    }
}
                    

proc twapi::get_global_group_info {grpname args} {
    array set opts [parseargs args {
        {system.arg ""}
        comment
        name
        members
        sid
        attributes
        all
    } -maxleftover 0]

    set result {}
    if {[expr {$opts(comment) || $opts(name) || $opts(sid) || $opts(attributes) || $opts(all)}]} {
        # 3 -> GROUP_INFO level 3
        lassign [NetGroupGetInfo $opts(system) $grpname 3] name comment sid attributes
        if {$opts(all) || $opts(sid)} {
            lappend result -sid $sid
        }
        if {$opts(all) || $opts(name)} {
            lappend result -name $name
        }
        if {$opts(all) || $opts(comment)} {
            lappend result -comment $comment
        }
        if {$opts(all) || $opts(attributes)} {
            lappend result -attributes [map_token_group_attr $attributes]
        }
    }

    if {$opts(all) || $opts(members)} {
        lappend result -members [get_global_group_members $grpname -system $opts(system)]
    }

    return $result
}

# Get info about a local or global group
proc twapi::get_local_group_info {name args} {
    array set opts [parseargs args {
        {system.arg ""}
        comment
        name
        members
        sid
        all
    } -maxleftover 0]

    set result [list ]
    if {$opts(all) || $opts(sid)} {
        lappend result -sid [lookup_account_name $name -system $opts(system)]
    }
    if {$opts(all) || $opts(comment) || $opts(name)} {
        lassign [NetLocalGroupGetInfo $opts(system) $name 1] name comment
        if {$opts(all) || $opts(name)} {
            lappend result -name $name
        }
        if {$opts(all) || $opts(comment)} {
            lappend result -comment $comment
        }
    }
    if {$opts(all) || $opts(members)} {
        lappend result -members [get_local_group_members $name -system $opts(system)]
    }
    return $result
}

# Get list of users on a system
proc twapi::get_users {args} {
    parseargs args {
        level.int
    } -setvars -ignoreunknown

    # TBD -allow user to specify filter
    lappend args -filter 0
    if {[info exists level]} {
        lappend args -level $level -fields [USER_INFO_$level]
    }
    return [_net_enum_helper NetUserEnum $args]
}

proc twapi::get_global_groups {args} {
    parseargs args {
        level.int
    } -setvars -ignoreunknown

    # TBD - level 3 returns an ERROR_INVALID_LEVEL even though
    # MSDN says its valid for NetGroupEnum

    if {[info exists level]} {
        lappend args -level $level -fields [GROUP_INFO_$level]
    }
    return [_net_enum_helper NetGroupEnum $args]
}

proc twapi::get_local_groups {args} {
    parseargs args {
        level.int
    } -setvars -ignoreunknown

    if {[info exists level]} {
        lappend args -level $level -fields [dict get {0 {-name} 1 {-name -comment}} $level]
    }
    return [_net_enum_helper NetLocalGroupEnum $args]
}

# Create a new global group
proc twapi::new_global_group {grpname args} {
    array set opts [parseargs args {
        system.arg
        comment.arg
    } -nulldefault]

    NetGroupAdd $opts(system) $grpname $opts(comment)
}

# Create a new local group
proc twapi::new_local_group {grpname args} {
    array set opts [parseargs args {
        system.arg
        comment.arg
    } -nulldefault]

    NetLocalGroupAdd $opts(system) $grpname $opts(comment)
}


# Delete a global group
proc twapi::delete_global_group {grpname args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    # Remove the group from the LSA rights database.
    _delete_rights $grpname $opts(system)

    NetGroupDel $opts(system) $grpname
}

# Delete a local group
proc twapi::delete_local_group {grpname args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    # Remove the group from the LSA rights database.
    _delete_rights $grpname $opts(system)

    NetLocalGroupDel $opts(system) $grpname
}


# Enumerate members of a global group
proc twapi::get_global_group_members {grpname args} {
    parseargs args {
        level.int
    } -setvars -ignoreunknown

    if {[info exists level]} {
        lappend args -level $level -fields [dict! {0 {-name} 1 {-name -attributes}} $level]
    }

    lappend args -preargs [list $grpname] -namelevel 1
    return [_net_enum_helper NetGroupGetUsers $args]
}

# Enumerate members of a local group
proc twapi::get_local_group_members {grpname args} {
    parseargs args {
        level.int
    } -setvars -ignoreunknown

    if {[info exists level]} {
        lappend args -level $level -fields [dict! {0 {-sid} 1 {-sid -sidusage -name} 2 {-sid -sidusage -domainandname} 3 {-domainandname}} $level]
    }

    lappend args -preargs [list $grpname] -namelevel 1 -namefield 2
    return [_net_enum_helper NetLocalGroupGetMembers $args]
}

# Add a user to a global group
proc twapi::add_user_to_global_group {grpname username args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    # No error if already member of the group
    trap {
        NetGroupAddUser $opts(system) $grpname $username
    } onerror {TWAPI_WIN32 1320} {
        # Ignore
    }
}


# Remove a user from a global group
proc twapi::remove_user_from_global_group {grpname username args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    trap {
        NetGroupDelUser $opts(system) $grpname $username
    } onerror {TWAPI_WIN32 1321} {
        # Was not in group - ignore
    }
}


# Add a user to a local group
proc twapi::add_member_to_local_group {grpname username args} {
    array set opts [parseargs args {
        system.arg
        {type.arg name}
    } -nulldefault]

    # No error if already member of the group
    trap {
        Twapi_NetLocalGroupMembers 0 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] [list $username]
    } onerror {TWAPI_WIN32 1378} {
        # Ignore
    }
}

proc twapi::add_members_to_local_group {grpname accts args} {
    array set opts [parseargs args {
        system.arg
        {type.arg name}
    } -nulldefault]

    Twapi_NetLocalGroupMembers 0 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] $accts
}


# Remove a user from a local group
proc twapi::remove_member_from_local_group {grpname username args} {
    array set opts [parseargs args {
        system.arg
        {type.arg name}
    } -nulldefault]

    trap {
        Twapi_NetLocalGroupMembers 1 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] [list $username]
    } onerror {TWAPI_WIN32 1377} {
        # Was not in group - ignore
    }
}

proc twapi::remove_members_from_local_group {grpname accts args} {
    array set opts [parseargs args {
        system.arg
        {type.arg name}
    } -nulldefault]

    Twapi_NetLocalGroupMembers 1 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] $accts
}


# Get rights for an account
proc twapi::get_account_rights {account args} {
    array set opts [parseargs args {
        {system.arg ""}
    } -maxleftover 0]

    set sid [map_account_to_sid $account -system $opts(system)]

    trap {
        set lsah [get_lsa_policy_handle -system $opts(system) -access policy_lookup_names]
        return [Twapi_LsaEnumerateAccountRights $lsah $sid]
    } onerror {TWAPI_WIN32 2} {
        # No specific rights for this account
        return [list ]
    } finally {
        if {[info exists lsah]} {
            close_lsa_policy_handle $lsah
        }
    }
}

# Get accounts having a specific right
proc twapi::find_accounts_with_right {right args} {
    array set opts [parseargs args {
        {system.arg ""}
        name
    } -maxleftover 0]

    trap {
        set lsah [get_lsa_policy_handle \
                      -system $opts(system) \
                      -access {
                          policy_lookup_names
                          policy_view_local_information
                      }]
        set accounts [list ]
        foreach sid [Twapi_LsaEnumerateAccountsWithUserRight $lsah $right] {
            if {$opts(name)} {
                if {[catch {lappend accounts [lookup_account_sid $sid -system $opts(system)]}]} {
                    # No mapping for SID - can happen if account has been
                    # deleted but LSA policy not updated accordingly
                    lappend accounts $sid
                }
            } else {
                lappend accounts $sid
            }
        }
        return $accounts
    } onerror {TWAPI_WIN32 259} {
        # No accounts have this right
        return [list ]
    } finally {
        if {[info exists lsah]} {
            close_lsa_policy_handle $lsah
        }
    }

}

# Add/remove rights to an account
proc twapi::_modify_account_rights {operation account rights args} {
    set switches {
        system.arg
        handle.arg
    }    

    switch -exact -- $operation {
        add {
            # Nothing to do
        }
        remove {
            lappend switches all
        }
        default {
            error "Invalid operation '$operation' specified"
        }
    }

    array set opts [parseargs args $switches -maxleftover 0]

    if {[info exists opts(system)] && [info exists opts(handle)]} {
        error "Options -system and -handle may not be specified together"
    }

    if {[info exists opts(handle)]} {
        set lsah $opts(handle)
        set sid $account
    } else {
        if {![info exists opts(system)]} {
            set opts(system) ""
        }

        set sid [map_account_to_sid $account -system $opts(system)]
        # We need to open a policy handle ourselves. First try to open
        # with max privileges in case the account needs to be created
        # and then retry with lower privileges if that fails
        catch {
            set lsah [get_lsa_policy_handle \
                          -system $opts(system) \
                          -access {
                              policy_lookup_names
                              policy_create_account
                          }]
        }
        if {![info exists lsah]} {
            set lsah [get_lsa_policy_handle \
                          -system $opts(system) \
                          -access policy_lookup_names]
        }
    }

    trap {
        if {$operation == "add"} {
            LsaAddAccountRights $lsah $sid $rights
        } else {
            LsaRemoveAccountRights $lsah $sid $opts(all) $rights
        }
    } finally {
        # Close the handle if we opened it
        if {! [info exists opts(handle)]} {
            close_lsa_policy_handle $lsah
        }
    }
}

interp alias {} twapi::add_account_rights {} twapi::_modify_account_rights add
interp alias {} twapi::remove_account_rights {} twapi::_modify_account_rights remove

# Return list of logon sesionss
proc twapi::find_logon_sessions {args} {
    array set opts [parseargs args {
        user.arg
        type.arg
        tssession.arg
    } -maxleftover 0]

    set luids [LsaEnumerateLogonSessions]
    if {! ([info exists opts(user)] || [info exists opts(type)] ||
           [info exists opts(tssession)])} {
        return $luids
    }


    # Need to get the data for each session to see if it matches
    set result [list ]
    if {[info exists opts(user)]} {
        set sid [map_account_to_sid $opts(user)]
    }
    if {[info exists opts(type)]} {
        set logontypes [list ]
        foreach logontype $opts(type) {
            lappend logontypes [_logon_session_type_code $logontype]
        }
    }

    foreach luid $luids {
        trap {
            unset -nocomplain session
            array set session [LsaGetLogonSessionData $luid]

            # For the local system account, no data is returned on some
            # platforms
            if {[array size session] == 0} {
                set session(Sid) S-1-5-18; # SYSTEM
                set session(Session) 0
                set session(LogonType) 0
            }
            if {[info exists opts(user)] && $session(Sid) ne $sid} {
                continue;               # User id does not match
            }

            if {[info exists opts(type)] && [lsearch -exact $logontypes $session(LogonType)] < 0} {
                continue;               # Type does not match
            }

            if {[info exists opts(tssession)] && $session(Session) != $opts(tssession)} {
                continue;               # Term server session does not match
            }

            lappend result $luid

        } onerror {TWAPI_WIN32 1312} {
            # Session no longer exists. Just skip
            continue
        }
    }

    return $result
}


# Return data for a logon session
proc twapi::get_logon_session_info {luid args} {
    array set opts [parseargs args {
        all
        authpackage
        dnsdomain
        logondomain
        logonid
        logonserver
        logontime
        type
        usersid
        user
        tssession
        userprincipal
    } -maxleftover 0]

    array set session [LsaGetLogonSessionData $luid]

    # Some fields may be missing on Win2K
    foreach fld {LogonServer DnsDomainName Upn} {
        if {![info exists session($fld)]} {
            set session($fld) ""
        }
    }

    array set result [list ]
    foreach {opt index} {
        authpackage AuthenticationPackage
        dnsdomain   DnsDomainName
        logondomain LogonDomain
        logonid     LogonId
        logonserver LogonServer
        logontime   LogonTime
        type        LogonType
        usersid         Sid
        user        UserName
        tssession   Session
        userprincipal Upn
    } {
        if {$opts(all) || $opts($opt)} {
            set result(-$opt) $session($index)
        }
    }

    if {[info exists result(-type)]} {
        set result(-type) [_logon_session_type_symbol $result(-type)]
    }

    return [array get result]
}




# Set/reset the given bits in the usri3_flags field for a user account
# mask indicates the mask of bits to set. values indicates the values
# of those bits
proc twapi::_change_user_info_flags {username mask values args} {
    array set opts [parseargs args {
        system.arg
    } -nulldefault -maxleftover 0]

    # Get current flags
    set flags [USER_INFO_1 -flags [NetUserGetInfo $opts(system) $username 1]]

    # Turn off mask bits and write flags back
    set flags [expr {$flags & (~ $mask)}]
    # Set the specified bits
    set flags [expr {$flags | ($values & $mask)}]

    # Write new flags back
    Twapi_NetUserSetInfo 1008 $opts(system) $username $flags
}

# Returns the logon session type value for a symbol
twapi::proc* twapi::_logon_session_type_code {type} {
    variable _logon_session_type_map
    # Variable that maps logon session type codes to integer values
    # Position of each symbol gives its corresponding type value
    # See ntsecapi.h for definitions
    set _logon_session_type_map {
        0
        1
        interactive
        network
        batch
        service
        proxy
        unlockworkstation
        networkclear
        newcredentials
        remoteinteractive
        cachedinteractive
        cachedremoteinteractive
        cachedunlockworkstation
    }
} {
    variable _logon_session_type_map

    # Type may be an integer or a token
    set code [lsearch -exact $_logon_session_type_map $type]
    if {$code >= 0} {
        return $code
    }

    if {![string is integer -strict $type]} {
        badargs! "Invalid logon session type '$type' specified" 3
    }
    return $type
}

# Returns the logon session type symbol for an integer value
proc twapi::_logon_session_type_symbol {code} {
    variable _logon_session_type_map
    _logon_session_type_code interactive; # Just to init _logon_session_type_map
    set symbol [lindex $_logon_session_type_map $code]
    if {$symbol eq ""} {
        return $code
    } else {
        return $symbol
    }
}

proc twapi::_set_user_priv_level {username priv_level args} {

    array set opts [parseargs args {system.arg} -nulldefault]

    if {0} {
        # FOr some reason NetUserSetInfo cannot change priv level
        # Tried it separately with a simple C program. So this code
        # is commented out and we use group membership to achieve
        # the desired result
        # Note: - latest MSDN confirms above
        if {![info exists twapi::priv_level_map($priv_level)]} {
            error "Invalid privilege level value '$priv_level' specified. Must be one of [join [array names twapi::priv_level_map] ,]"
        }
        set priv $twapi::priv_level_map($priv_level)

        Twapi_NetUserSetInfo_priv $opts(system) $username $priv
    } else {
        # Don't hardcode group names - reverse map SID's instead for 
        # non-English systems. Also note that since
        # we might be lowering privilege level, we have to also
        # remove from higher privileged groups

        switch -exact -- $priv_level {
            guest {
                # administrators users
                set outgroups {S-1-5-32-544 S-1-5-32-545}
                # guests
                set ingroup S-1-5-32-546
            }
            user  {
                # administrators
                set outgroups {S-1-5-32-544}
                # users
                set ingroup S-1-5-32-545
            }
            admin {
                set outgroups {}
                set ingroup S-1-5-32-544
            }
            default {error "Invalid privilege level '$priv_level'. Must be one of 'guest', 'user' or 'admin'"}
        }
        # Remove from higher priv groups
        foreach outgroup $outgroups {
            # Get the potentially localized name of the group
            set group [lookup_account_sid $outgroup -system $opts(system)]
            # Catch since may not be member of that group
            catch {remove_member_from_local_group $group $username -system $opts(system)}
        }

        # Get the potentially localized name of the group to be added
        set group [lookup_account_sid $ingroup -system $opts(system)]
        add_member_to_local_group $group $username -system $opts(system)
    }
}

proc twapi::_map_userinfo_flags {flags} {
    # UF_LOCKOUT -> 0x10, UF_ACCOUNTDISABLE -> 0x2
    if {$flags & 0x2} {
        set status disabled
    } elseif {$flags & 0x10} {
        set status locked
    } else {
        set status enabled
    }

    #define UF_TEMP_DUPLICATE_ACCOUNT       0x0100
    #define UF_NORMAL_ACCOUNT               0x0200
    #define UF_INTERDOMAIN_TRUST_ACCOUNT    0x0800
    #define UF_WORKSTATION_TRUST_ACCOUNT    0x1000
    #define UF_SERVER_TRUST_ACCOUNT         0x2000
    if {$flags & 0x0200} {
        set type normal
    } elseif {$flags & 0x0100} {
        set type duplicate
    } elseif {$flags & 0x0800} {
        set type interdomain_trust
    } elseif {$flags & 0x1000} {
        set type workstation_trust
    } elseif {$flags & 0x2000} {
        set type server_trust
    } else {
        set type unknown
    }

    set pw {}
    #define UF_PASSWD_NOTREQD                  0x0020
    if {$flags & 0x0020} {
        lappend pw not_required
    }
    #define UF_PASSWD_CANT_CHANGE              0x0040
    if {$flags & 0x0040} {
        lappend pw cannot_change
    }
    #define UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED 0x0080
    if {$flags & 0x0080} {
        lappend pw encrypted_text_allowed
    }
    #define UF_DONT_EXPIRE_PASSWD                         0x10000
    if {$flags & 0x10000} {
        lappend pw no_expiry
    }
    #define UF_SMARTCARD_REQUIRED                         0x40000
    if {$flags & 0x40000} {
        lappend pw smartcard_required
    }
    #define UF_PASSWORD_EXPIRED                          0x800000
    if {$flags & 0x800000} {
        lappend pw expired
    }

    return [list -status $status -type $type -password_attrs $pw]
}

twapi::proc* twapi::_define_user_modals {} {
    struct _USER_MODALS_INFO_0 {
        DWORD min_passwd_len;
        DWORD max_passwd_age;
        DWORD min_passwd_age;
        DWORD force_logoff;
        DWORD password_hist_len;
    }
    struct _USER_MODALS_INFO_1 {
        DWORD  role;
        LPWSTR primary;
    }
    struct _USER_MODALS_INFO_2 {
        LPWSTR domain_name;
        PSID   domain_id;
    }
    struct _USER_MODALS_INFO_3 {
        DWORD lockout_duration;
        DWORD lockout_observation_window;
        DWORD lockout_threshold;
    }
    struct _USER_MODALS_INFO_1001 {
        DWORD min_passwd_len;
    }
    struct _USER_MODALS_INFO_1002 {
        DWORD max_passwd_age;
    }
    struct _USER_MODALS_INFO_1003 {
        DWORD min_passwd_age;
    }
    struct _USER_MODALS_INFO_1004 {
        DWORD force_logoff;
    }
    struct _USER_MODALS_INFO_1005 {
        DWORD password_hist_len;
    }
    struct _USER_MODALS_INFO_1006 {
        DWORD role;
    }
    struct _USER_MODALS_INFO_1007 {
        LPWSTR primary;
    }
} {
}

twapi::proc* twapi::get_password_policy {{server_name ""}} {
    _define_user_modals
} {
    set result [NetUserModalsGet $server_name 0 [_USER_MODALS_INFO_0]]
    dict with result {
        if {$force_logoff == 4294967295 || $force_logoff == -1} {
            set force_logoff never
        }
        if {$max_passwd_age == 4294967295 || $max_passwd_age == -1} {
            set max_passwd_age none
        }
    }
    return $result
}

# TBD - doc & test
twapi::proc* twapi::get_system_role {{server_name ""}} {
    _define_user_modals
} {
    set result [NetUserModalsGet $server_name 1 [_USER_MODALS_INFO_1]]
    dict set result role [dict* {
        0 standalone 1 member 2 backup 3 primary
    } [dict get $result role]]
    return $result
}

# TBD - doc & test
twapi::proc* twapi::get_system_domain {{server_name ""}} {
    _define_user_modals
} {
    return [NetUserModalsGet $server_name 2 [_USER_MODALS_INFO_2]]
}

twapi::proc* twapi::get_lockout_policy {{server_name ""}} {
    _define_user_modals
} {
    return [NetUserModalsGet $server_name 3 [_USER_MODALS_INFO_3]]
}

# TBD - doc & test
twapi::proc* twapi::set_password_policy {name val {server_name ""}} {
    _define_user_modals
} {
    switch -exact $name {
        min_passwd_len {
            NetUserModalsSet $server_name 1001 [_USER_MODALS_INFO_1001 $val]
        }
        max_passwd_age {
            if {$val eq "none"} {
                set val 4294967295
            }
            NetUserModalsSet $server_name 1002 [_USER_MODALS_INFO_1002 $val]
        }
        min_passwd_age {
            NetUserModalsSet $server_name 1003 [_USER_MODALS_INFO_1003 $val]
        }
        force_logoff {
            if {$val eq "never"} {
                set val 4294967295
            }
            NetUserModalsSet $server_name 1004 [_USER_MODALS_INFO_1004 $val]
        }
        password_hist_len {
            NetUserModalsSet $server_name 1005 [_USER_MODALS_INFO_1005 $val]
        }
    }
}

# TBD - doc & test
twapi::proc* twapi::set_lockout_policy {duration observe_window threshold {server_name ""}} {
    _define_user_modals
} {
    NetUserModalsSet $server_name 3 [_USER_MODALS_INFO_3 $duration $observe_window $threshold]
}

#
# Copyright (c) 2010-2012, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# ADSI routines

# TBD - document
proc twapi::adsi_translate_name {name to {from 0}} {
    set map {
        unknown 0 fqdn 1 samcompatible 2 display 3 uniqueid 6
        canonical 7 userprincipal 8 canonicalex 9 serviceprincipal 10
        dnsdomain 12
    }
    if {! [string is integer -strict $to]} {
        set to [dict get $map $to]
        if {$to == 0} {
            error "'unknown' is not a valid target format."
        }
    }

    if {! [string is integer -strict $from]} {
        set from [dict get $map $from]
    }
        
    return [TranslateName $name $from $to]
}

#
# Copyright (c) 2003-2012, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

namespace eval twapi {}

# Get the command line
proc twapi::get_command_line {} {
    return [GetCommandLineW]
}

# Parse the command line
proc twapi::get_command_line_args {cmdline} {
    # Special check for empty line. CommandLinetoArgv returns process
    # exe name in this case.
    if {[string length $cmdline] == 0} {
        return [list ]
    }
    return [CommandLineToArgv $cmdline]
}

# Read an ini file int
proc twapi::read_inifile_key {section key args} {
    array set opts [parseargs args {
        {default.arg ""}
        inifile.arg
    } -maxleftover 0]

    if {[info exists opts(inifile)]} {
        set values [read_inifile_section $section -inifile $opts(inifile)]
    } else {
        set values [read_inifile_section $section]
    }

    # Cannot use kl_get or arrays here because we want case insensitive compare
    foreach {k val} $values {
        if {[string equal -nocase $key $k]} {
            return $val
        }
    }
    return $opts(default)
}

# Write an ini file string
proc twapi::write_inifile_key {section key value args} {
    array set opts [parseargs args {
        inifile.arg
    } -maxleftover 0]

    if {[info exists opts(inifile)]} {
        WritePrivateProfileString $section $key $value $opts(inifile)
    } else {
        WriteProfileString $section $key $value
    }
}

# Delete an ini file string
proc twapi::delete_inifile_key {section key args} {
    array set opts [parseargs args {
        inifile.arg
    } -maxleftover 0]

    if {[info exists opts(inifile)]} {
        WritePrivateProfileString $section $key $twapi::nullptr $opts(inifile)
    } else {
        WriteProfileString $section $key $twapi::nullptr
    }
}

# Get names of the sections in an inifile
proc twapi::read_inifile_section_names {args} {
    array set opts [parseargs args {
        inifile.arg
    } -nulldefault -maxleftover 0]

    return [GetPrivateProfileSectionNames $opts(inifile)]
}

# Get keys and values in a section in an inifile
proc twapi::read_inifile_section {section args} {
    array set opts [parseargs args {
        inifile.arg
    } -nulldefault -maxleftover 0]

    set result [list ]
    foreach line [GetPrivateProfileSection $section $opts(inifile)] {
        set pos [string first "=" $line]
        if {$pos >= 0} {
            lappend result [string range $line 0 [expr {$pos-1}]] [string range $line [incr pos] end]
        }
    }
    return $result
}


# Delete an ini file section
proc twapi::delete_inifile_section {section args} {
    variable nullptr

    array set opts [parseargs args {
        inifile.arg
    }]

    if {[info exists opts(inifile)]} {
        WritePrivateProfileString $section $nullptr $nullptr $opts(inifile)
    } else {
        WriteProfileString $section $nullptr $nullptr
    }
}

#
# Copyright (c) 2012-2014, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# Commands in twapi_base module

namespace eval twapi {
    # Map of Sid integer type to Sid type name
    array set sid_type_names {
        1 user 
        2 group
        3 domain 
        4 alias 
        5 wellknowngroup
        6 deletedaccount
        7 invalid
        8 unknown
        9 computer
        10 label
    }

    # Cache mapping account names to SIDs. Dict keyed by system and name
    variable _name_to_sid_cache {}

    # Cache mapping SIDs to account names. Dict keyed by system and SID
    variable _sid_to_name_cache {}

}



# Return major minor servicepack as a quad list
proc twapi::get_os_version {} {
    array set verinfo [GetVersionEx]
    return [list $verinfo(dwMajorVersion) $verinfo(dwMinorVersion) \
                $verinfo(wServicePackMajor) $verinfo(wServicePackMinor)]
}

# Returns true if the OS version is at least $major.$minor.$sp
proc twapi::min_os_version {major {minor 0} {spmajor 0} {spminor 0}} {
    lassign  [twapi::get_os_version]  osmajor osminor osspmajor osspminor

    if {$osmajor > $major} {return 1}
    if {$osmajor < $major} {return 0}
    if {$osminor > $minor} {return 1}
    if {$osminor < $minor} {return 0}
    if {$osspmajor > $spmajor} {return 1}
    if {$osspmajor < $spmajor} {return 0}
    if {$osspminor > $spminor} {return 1}
    if {$osspminor < $spminor} {return 0}

    # Same version, ok
    return 1
}

# Convert a LARGE_INTEGER time value (100ns since 1601) to a formatted date
# time
interp alias {} twapi::large_system_time_to_secs {} twapi::large_system_time_to_secs_since_1970
proc twapi::large_system_time_to_secs_since_1970 {ns100 {fraction false}} {
    # No. 100ns units between 1601 to 1970 = 116444736000000000
    set ns100_since_1970 [expr {$ns100-116444736000000000}]

    set secs_since_1970 [expr {$ns100_since_1970/10000000}]
    if {$fraction} {
        append secs_since_1970 .[string range $ns100 end-6 end]
    }
    return $secs_since_1970
}

proc twapi::secs_since_1970_to_large_system_time {secs} {
    # No. 100ns units between 1601 to 1970 = 116444736000000000
    return [expr {($secs * 10000000) + 116444736000000000}]
}

# Map a Windows error code to a string
proc twapi::map_windows_error {code} {
    # Trim trailing CR/LF
    return [string trimright [twapi::Twapi_MapWindowsErrorToString $code] "\r\n"]
}

# Load given library
proc twapi::load_library {path args} {
    array set opts [parseargs args {
        dontresolverefs
        datafile
        alteredpath
    }]

    set flags 0
    if {$opts(dontresolverefs)} {
        setbits flags 1;                # DONT_RESOLVE_DLL_REFERENCES
    }
    if {$opts(datafile)} {
        setbits flags 2;                # LOAD_LIBRARY_AS_DATAFILE
    }
    if {$opts(alteredpath)} {
        setbits flags 8;                # LOAD_WITH_ALTERED_SEARCH_PATH
    }

    # LoadLibrary always wants backslashes
    set path [file nativename $path]
    return [LoadLibraryEx $path $flags]
}

# Free library opened with load_library
proc twapi::free_library {libh} {
    FreeLibrary $libh
}

# Format message string - will raise exception if insufficient number
# of arguments
proc twapi::_unsafe_format_message {args} {
    array set opts [parseargs args {
        module.arg
        fmtstring.arg
        messageid.arg
        langid.arg
        params.arg
        includesystem
        ignoreinserts
        width.int
    } -nulldefault -maxleftover 0]

    set flags 0

    if {$opts(module) == ""} {
        if {$opts(fmtstring) == ""} {
            # If neither -module nor -fmtstring specified, message is formatted
            # from the system
            set opts(module) NULL
            setbits flags 0x1000;       # FORMAT_MESSAGE_FROM_SYSTEM
        } else {
            setbits flags 0x400;        # FORMAT_MESSAGE_FROM_STRING
            if {$opts(includesystem) || $opts(messageid) != "" || $opts(langid) != ""} {
                error "Options -includesystem, -messageid and -langid cannot be used with -fmtstring"
            }
        }
    } else {
        if {$opts(fmtstring) != ""} {
            error "Options -fmtstring and -module cannot be used together"
        }
        setbits flags 0x800;        # FORMAT_MESSAGE_FROM_HMODULE
        if {$opts(includesystem)} {
            # Also include system in search
            setbits flags 0x1000;       # FORMAT_MESSAGE_FROM_SYSTEM
        }
    }

    if {$opts(ignoreinserts)} {
        setbits flags 0x200;            # FORMAT_MESSAGE_IGNORE_INSERTS
    }

    if {$opts(width) > 254} {
        error "Invalid value for option -width. Must be -1, 0, or a positive integer less than 255"
    }
    if {$opts(width) < 0} {
        # Negative width means no width restrictions
        set opts(width) 255;                  # 255 -> no restrictions
    }
    incr flags $opts(width);                  # Width goes in low byte of flags

    if {$opts(fmtstring) != ""} {
        return [FormatMessageFromString $flags $opts(fmtstring) $opts(params)]
    } else {
        if {![string is integer -strict $opts(messageid)]} {
            error "Unspecified or invalid value for -messageid option. Must be an integer value"
        }
        if {$opts(langid) == ""} { set opts(langid) 0 }
        if {![string is integer -strict $opts(langid)]} {
            error "Unspecfied or invalid value for -langid option. Must be an integer value"
        }

        # Check if $opts(module) is a file or module handle (pointer)
        if {[pointer? $opts(module)]} {
            return  [FormatMessageFromModule $flags $opts(module) \
                         $opts(messageid) $opts(langid) $opts(params)]
        } else {
            set hmod [load_library $opts(module) -datafile]
            trap {
                set message  [FormatMessageFromModule $flags $hmod \
                                  $opts(messageid) $opts(langid) $opts(params)]
            } finally {
                free_library $hmod
            }
            return $message
        }
    }
}

# Format message string
proc twapi::format_message {args} {
    array set opts [parseargs args {
        params.arg
        fmtstring.arg
        width.int
        ignoreinserts
    } -ignoreunknown]

    # TBD - document - if no params specified, different from params = {}

    # If a format string is specified, other options do not matter
    # except for -width. In that case, we do not call FormatMessage
    # at all
    if {[info exists opts(fmtstring)]} {
        # If -width specifed, call FormatMessage
        if {[info exists opts(width)] && $opts(width)} {
            set msg [_unsafe_format_message -ignoreinserts -fmtstring $opts(fmtstring) -width $opts(width) {*}$args]
        } else {
            set msg $opts(fmtstring)
        }
    } else {
        # Not -fmtstring, retrieve from message file
        if {[info exists opts(width)]} {
            set msg [_unsafe_format_message -ignoreinserts -width $opts(width) {*}$args]
        } else {
            set msg [_unsafe_format_message -ignoreinserts {*}$args]
        }
    }

    # If we are told to ignore inserts, all done. Else replace them except
    # that if no param list, do not replace placeholder. This is NOT
    # the same as empty param list
    if {$opts(ignoreinserts) || ![info exists opts(params)]} {
        return $msg
    }

    # TBD - cache fmtstring -> indices for performance
    set placeholder_indices [regexp -indices -all -inline {%(?:.|(?:[1-9][0-9]?(?:![^!]+!)?))} $msg]

    if {[llength $placeholder_indices] == 0} {
        # No placeholders.
        return $msg
    }

    # Use of * in format specifiers will change where the actual parameters
    # are positioned
    set num_asterisks 0
    set msg2 ""
    set prev_end 0
    foreach placeholder $placeholder_indices {
        lassign $placeholder start end
        # Append the stuff between previous placeholder and this one
        append msg2 [string range $msg $prev_end [expr {$start-1}]]
        set spec [string range $msg $start+1 $end]
        switch -exact -- [string index $spec 0] {
            % { append msg2 % }
            r { append msg2 \r }
            n { append msg2 \n }
            t { append msg2 \t }
            0 { 
                # No-op - %0 means to not add trailing newline
            }
            default {
                if {! [string is integer -strict [string index $spec 0]]} {
                    # Not a insert parameter. Just append the character
                    append msg2 $spec
                } else {
                    # Insert parameter
                    set fmt ""
                    scan $spec %d%s param_index fmt
                    # Note params are numbered starting with 1
                    incr param_index -1
                    # Format spec, if present, is enclosed in !. Get rid of them
                    set fmt [string trim $fmt "!"]
                    if {$fmt eq ""} {
                        # No fmt spec
                    } else {
                        # Since everything is a string in Tcl, we happily
                        # do not have to worry about type. However, the
                        # format spec could have * specifiers which will
                        # change the parameter indexing for subsequent
                        # arguments
                        incr num_asterisks [expr {[llength [split $fmt *]]-1}]
                        incr param_index $num_asterisks
                    }
                    # TBD - we ignore the actual format type
                    append msg2 [lindex $opts(params) $param_index]
                }                        
            }
        }                    
        set prev_end [incr end]
    }
    append msg2 [string range $msg $prev_end end]
    return $msg2
}

# Revert to process token. In base package because used across many modules
proc twapi::revert_to_self {{opt ""}} {
    RevertToSelf
}

# For backward compatibility
interp alias {} twapi::expand_environment_strings {} twapi::expand_environment_vars

proc twapi::_init_security_defs {} {
    variable security_defs

    # NOTE : the access definitions for those types that are included here
    # have been updated as of Windows 8.
    array set security_defs {

        TOKEN_ASSIGN_PRIMARY           0x00000001
        TOKEN_DUPLICATE                0x00000002
        TOKEN_IMPERSONATE              0x00000004
        TOKEN_QUERY                    0x00000008
        TOKEN_QUERY_SOURCE             0x00000010
        TOKEN_ADJUST_PRIVILEGES        0x00000020
        TOKEN_ADJUST_GROUPS            0x00000040
        TOKEN_ADJUST_DEFAULT           0x00000080
        TOKEN_ADJUST_SESSIONID         0x00000100

        TOKEN_ALL_ACCESS_WINNT         0x000F00FF
        TOKEN_ALL_ACCESS_WIN2K         0x000F01FF
        TOKEN_ALL_ACCESS               0x000F01FF
        TOKEN_READ                     0x00020008
        TOKEN_WRITE                    0x000200E0
        TOKEN_EXECUTE                  0x00020000

        SYSTEM_MANDATORY_LABEL_NO_WRITE_UP         0x1
        SYSTEM_MANDATORY_LABEL_NO_READ_UP          0x2
        SYSTEM_MANDATORY_LABEL_NO_EXECUTE_UP       0x4

        ACL_REVISION     2
        ACL_REVISION_DS  4

        ACCESS_MAX_MS_V2_ACE_TYPE               0x3
        ACCESS_MAX_MS_V3_ACE_TYPE               0x4
        ACCESS_MAX_MS_V4_ACE_TYPE               0x8
        ACCESS_MAX_MS_V5_ACE_TYPE               0x11

        STANDARD_RIGHTS_REQUIRED       0x000F0000
        STANDARD_RIGHTS_READ           0x00020000
        STANDARD_RIGHTS_WRITE          0x00020000
        STANDARD_RIGHTS_EXECUTE        0x00020000
        STANDARD_RIGHTS_ALL            0x001F0000
        SPECIFIC_RIGHTS_ALL            0x0000FFFF

        GENERIC_READ                   0x80000000
        GENERIC_WRITE                  0x40000000
        GENERIC_EXECUTE                0x20000000
        GENERIC_ALL                    0x10000000

        SERVICE_QUERY_CONFIG           0x00000001
        SERVICE_CHANGE_CONFIG          0x00000002
        SERVICE_QUERY_STATUS           0x00000004
        SERVICE_ENUMERATE_DEPENDENTS   0x00000008
        SERVICE_START                  0x00000010
        SERVICE_STOP                   0x00000020
        SERVICE_PAUSE_CONTINUE         0x00000040
        SERVICE_INTERROGATE            0x00000080
        SERVICE_USER_DEFINED_CONTROL   0x00000100
        SERVICE_ALL_ACCESS             0x000F01FF

        SC_MANAGER_CONNECT             0x00000001
        SC_MANAGER_CREATE_SERVICE      0x00000002
        SC_MANAGER_ENUMERATE_SERVICE   0x00000004
        SC_MANAGER_LOCK                0x00000008
        SC_MANAGER_QUERY_LOCK_STATUS   0x00000010
        SC_MANAGER_MODIFY_BOOT_CONFIG  0x00000020
        SC_MANAGER_ALL_ACCESS          0x000F003F

        KEY_QUERY_VALUE                0x00000001
        KEY_SET_VALUE                  0x00000002
        KEY_CREATE_SUB_KEY             0x00000004
        KEY_ENUMERATE_SUB_KEYS         0x00000008
        KEY_NOTIFY                     0x00000010
        KEY_CREATE_LINK                0x00000020
        KEY_WOW64_32KEY                0x00000200
        KEY_WOW64_64KEY                0x00000100
        KEY_WOW64_RES                  0x00000300
        KEY_READ                       0x00020019
        KEY_WRITE                      0x00020006
        KEY_EXECUTE                    0x00020019
        KEY_ALL_ACCESS                 0x000F003F

        POLICY_VIEW_LOCAL_INFORMATION   0x00000001
        POLICY_VIEW_AUDIT_INFORMATION   0x00000002
        POLICY_GET_PRIVATE_INFORMATION  0x00000004
        POLICY_TRUST_ADMIN              0x00000008
        POLICY_CREATE_ACCOUNT           0x00000010
        POLICY_CREATE_SECRET            0x00000020
        POLICY_CREATE_PRIVILEGE         0x00000040
        POLICY_SET_DEFAULT_QUOTA_LIMITS 0x00000080
        POLICY_SET_AUDIT_REQUIREMENTS   0x00000100
        POLICY_AUDIT_LOG_ADMIN          0x00000200
        POLICY_SERVER_ADMIN             0x00000400
        POLICY_LOOKUP_NAMES             0x00000800
        POLICY_NOTIFICATION             0x00001000
        POLICY_READ                     0X00020006
        POLICY_WRITE                    0X000207F8
        POLICY_EXECUTE                  0X00020801
        POLICY_ALL_ACCESS               0X000F0FFF

        DESKTOP_READOBJECTS         0x0001
        DESKTOP_CREATEWINDOW        0x0002
        DESKTOP_CREATEMENU          0x0004
        DESKTOP_HOOKCONTROL         0x0008
        DESKTOP_JOURNALRECORD       0x0010
        DESKTOP_JOURNALPLAYBACK     0x0020
        DESKTOP_ENUMERATE           0x0040
        DESKTOP_WRITEOBJECTS        0x0080
        DESKTOP_SWITCHDESKTOP       0x0100

        WINSTA_ENUMDESKTOPS         0x0001
        WINSTA_READATTRIBUTES       0x0002
        WINSTA_ACCESSCLIPBOARD      0x0004
        WINSTA_CREATEDESKTOP        0x0008
        WINSTA_WRITEATTRIBUTES      0x0010
        WINSTA_ACCESSGLOBALATOMS    0x0020
        WINSTA_EXITWINDOWS          0x0040
        WINSTA_ENUMERATE            0x0100
        WINSTA_READSCREEN           0x0200
        WINSTA_ALL_ACCESS           0x37f

        PROCESS_TERMINATE              0x0001
        PROCESS_CREATE_THREAD          0x0002
        PROCESS_SET_SESSIONID          0x0004
        PROCESS_VM_OPERATION           0x0008
        PROCESS_VM_READ                0x0010
        PROCESS_VM_WRITE               0x0020
        PROCESS_DUP_HANDLE             0x0040
        PROCESS_CREATE_PROCESS         0x0080
        PROCESS_SET_QUOTA              0x0100
        PROCESS_SET_INFORMATION        0x0200
        PROCESS_QUERY_INFORMATION      0x0400
        PROCESS_SUSPEND_RESUME         0x0800

        THREAD_TERMINATE               0x00000001
        THREAD_SUSPEND_RESUME          0x00000002
        THREAD_GET_CONTEXT             0x00000008
        THREAD_SET_CONTEXT             0x00000010
        THREAD_SET_INFORMATION         0x00000020
        THREAD_QUERY_INFORMATION       0x00000040
        THREAD_SET_THREAD_TOKEN        0x00000080
        THREAD_IMPERSONATE             0x00000100
        THREAD_DIRECT_IMPERSONATION    0x00000200
        THREAD_SET_LIMITED_INFORMATION   0x00000400
        THREAD_QUERY_LIMITED_INFORMATION 0x00000800

        EVENT_MODIFY_STATE             0x00000002
        EVENT_ALL_ACCESS               0x001F0003

        SEMAPHORE_MODIFY_STATE         0x00000002
        SEMAPHORE_ALL_ACCESS           0x001F0003

        MUTANT_QUERY_STATE             0x00000001
        MUTANT_ALL_ACCESS              0x001F0001

        MUTEX_MODIFY_STATE             0x00000001
        MUTEX_ALL_ACCESS               0x001F0001

        TIMER_QUERY_STATE              0x00000001
        TIMER_MODIFY_STATE             0x00000002
        TIMER_ALL_ACCESS               0x001F0003

        FILE_READ_DATA                 0x00000001
        FILE_LIST_DIRECTORY            0x00000001
        FILE_WRITE_DATA                0x00000002
        FILE_ADD_FILE                  0x00000002
        FILE_APPEND_DATA               0x00000004
        FILE_ADD_SUBDIRECTORY          0x00000004
        FILE_CREATE_PIPE_INSTANCE      0x00000004
        FILE_READ_EA                   0x00000008
        FILE_WRITE_EA                  0x00000010
        FILE_EXECUTE                   0x00000020
        FILE_TRAVERSE                  0x00000020
        FILE_DELETE_CHILD              0x00000040
        FILE_READ_ATTRIBUTES           0x00000080
        FILE_WRITE_ATTRIBUTES          0x00000100

        FILE_ALL_ACCESS                0x001F01FF
        FILE_GENERIC_READ              0x00120089
        FILE_GENERIC_WRITE             0x00120116
        FILE_GENERIC_EXECUTE           0x001200A0

        DELETE                         0x00010000
        READ_CONTROL                   0x00020000
        WRITE_DAC                      0x00040000
        WRITE_OWNER                    0x00080000
        SYNCHRONIZE                    0x00100000

        COM_RIGHTS_EXECUTE 1
        COM_RIGHTS_EXECUTE_LOCAL 2
        COM_RIGHTS_EXECUTE_REMOTE 4
        COM_RIGHTS_ACTIVATE_LOCAL 8
        COM_RIGHTS_ACTIVATE_REMOTE 16
    }

    if {[min_os_version 6]} {
        array set security_defs {
            PROCESS_QUERY_LIMITED_INFORMATION      0x00001000
            PROCESS_ALL_ACCESS             0x001fffff
            THREAD_ALL_ACCESS              0x001fffff
        }
    } else {
        array set security_defs {
            PROCESS_ALL_ACCESS             0x001f0fff
            THREAD_ALL_ACCESS              0x001f03ff
        }
    }

    # Make next call a no-op
    proc _init_security_defs {} {}
}

# Map a set of access right symbols to a flag. Concatenates
# all the arguments, and then OR's the individual elements. Each
# element may either be a integer or one of the access rights
proc twapi::_access_rights_to_mask {args} {
    _init_security_defs

    proc _access_rights_to_mask args {
        variable security_defs
        set rights 0
        foreach right [concat {*}$args] {
            # The mandatory label access rights are not in security_defs
            # because we do not want them to mess up the int->name mapping
            # for DACL's
            set right [dict* {
                no_write_up 1
                system_mandatory_label_no_write_up 1
                no_read_up 2
                system_mandatory_label_no_read_up  2
                no_execute_up 4
                system_mandatory_label_no_execute_up 4
            } $right]
            if {![string is integer $right]} {
                if {[catch {set right $security_defs([string toupper $right])}]} {
                    error "Invalid access right symbol '$right'"
                }
            }
            set rights [expr {$rights | $right}]
        }
        return $rights
    }
    return [_access_rights_to_mask {*}$args]
}


# Map an access mask to a set of rights
proc twapi::_access_mask_to_rights {access_mask {type ""}} {
    _init_security_defs

    proc _access_mask_to_rights {access_mask {type ""}} {
        variable security_defs

        set rights [list ]

        if {$type eq "mandatory_label"} {
            if {$access_mask & 1} {
                lappend rights system_mandatory_label_no_write_up
            }
            if {$access_mask & 2} {
                lappend rights system_mandatory_label_no_read_up
            }
            if {$access_mask & 4} {
                lappend rights system_mandatory_label_no_execute_up
            }
            return $rights
        }

        # The returned list will include rights that map to multiple bits
        # as well as the individual bits. We first add the multiple bits
        # and then the individual bits (since we clear individual bits
        # after adding)

        #
        # Check standard multiple bit masks
        #
        foreach x {STANDARD_RIGHTS_REQUIRED STANDARD_RIGHTS_READ STANDARD_RIGHTS_WRITE STANDARD_RIGHTS_EXECUTE STANDARD_RIGHTS_ALL SPECIFIC_RIGHTS_ALL} {
            if {($security_defs($x) & $access_mask) == $security_defs($x)} {
                lappend rights [string tolower $x]
            }
        }

        #
        # Check type specific multiple bit masks.
        #
        
        set type_mask_map {
            file {FILE_ALL_ACCESS FILE_GENERIC_READ FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE}
            process {PROCESS_ALL_ACCESS}
            pipe {FILE_ALL_ACCESS}
            policy {POLICY_READ POLICY_WRITE POLICY_EXECUTE POLICY_ALL_ACCESS}
            registry {KEY_READ KEY_WRITE KEY_EXECUTE KEY_ALL_ACCESS}
            service {SERVICE_ALL_ACCESS}
            thread {THREAD_ALL_ACCESS}
            token {TOKEN_READ TOKEN_WRITE TOKEN_EXECUTE TOKEN_ALL_ACCESS}
            desktop {}
            winsta {WINSTA_ALL_ACCESS}
        }
        if {[dict exists $type_mask_map $type]} {
            foreach x [dict get $type_mask_map $type] {
                if {($security_defs($x) & $access_mask) == $security_defs($x)} {
                    lappend rights [string tolower $x]
                }
            }
        }

        #
        # OK, now map individual bits

        # First map the common bits
        foreach x {DELETE READ_CONTROL WRITE_DAC WRITE_OWNER SYNCHRONIZE} {
            if {$security_defs($x) & $access_mask} {
                lappend rights [string tolower $x]
                resetbits access_mask $security_defs($x)
            }
        }

        # Then the generic bits
        foreach x {GENERIC_READ GENERIC_WRITE GENERIC_EXECUTE GENERIC_ALL} {
            if {$security_defs($x) & $access_mask} {
                lappend rights [string tolower $x]
                resetbits access_mask $security_defs($x)
            }
        }

        # Then the type specific
        set type_mask_map {
            file { FILE_READ_DATA FILE_WRITE_DATA FILE_APPEND_DATA
                FILE_READ_EA FILE_WRITE_EA FILE_EXECUTE
                FILE_DELETE_CHILD FILE_READ_ATTRIBUTES
                FILE_WRITE_ATTRIBUTES }
            pipe { FILE_READ_DATA FILE_WRITE_DATA FILE_CREATE_PIPE_INSTANCE
                FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES }
            service { SERVICE_QUERY_CONFIG SERVICE_CHANGE_CONFIG
                SERVICE_QUERY_STATUS SERVICE_ENUMERATE_DEPENDENTS
                SERVICE_START SERVICE_STOP SERVICE_PAUSE_CONTINUE
                SERVICE_INTERROGATE SERVICE_USER_DEFINED_CONTROL }
            registry { KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
                KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
                KEY_WOW64_32KEY KEY_WOW64_64KEY KEY_WOW64_RES }
            policy { POLICY_VIEW_LOCAL_INFORMATION POLICY_VIEW_AUDIT_INFORMATION
                POLICY_GET_PRIVATE_INFORMATION POLICY_TRUST_ADMIN
                POLICY_CREATE_ACCOUNT POLICY_CREATE_SECRET
                POLICY_CREATE_PRIVILEGE POLICY_SET_DEFAULT_QUOTA_LIMITS
                POLICY_SET_AUDIT_REQUIREMENTS POLICY_AUDIT_LOG_ADMIN
                POLICY_SERVER_ADMIN POLICY_LOOKUP_NAMES }
            process { PROCESS_TERMINATE PROCESS_CREATE_THREAD
                PROCESS_SET_SESSIONID PROCESS_VM_OPERATION
                PROCESS_VM_READ PROCESS_VM_WRITE PROCESS_DUP_HANDLE
                PROCESS_CREATE_PROCESS PROCESS_SET_QUOTA
                PROCESS_SET_INFORMATION PROCESS_QUERY_INFORMATION
                PROCESS_SUSPEND_RESUME} 
            thread { THREAD_TERMINATE THREAD_SUSPEND_RESUME
                THREAD_GET_CONTEXT THREAD_SET_CONTEXT
                THREAD_SET_INFORMATION THREAD_QUERY_INFORMATION
                THREAD_SET_THREAD_TOKEN THREAD_IMPERSONATE
                THREAD_DIRECT_IMPERSONATION
                THREAD_SET_LIMITED_INFORMATION
                THREAD_QUERY_LIMITED_INFORMATION }
            token { TOKEN_ASSIGN_PRIMARY TOKEN_DUPLICATE TOKEN_IMPERSONATE
                TOKEN_QUERY TOKEN_QUERY_SOURCE TOKEN_ADJUST_PRIVILEGES
                TOKEN_ADJUST_GROUPS TOKEN_ADJUST_DEFAULT TOKEN_ADJUST_SESSIONID }
            desktop { DESKTOP_READOBJECTS DESKTOP_CREATEWINDOW
                DESKTOP_CREATEMENU DESKTOP_HOOKCONTROL
                DESKTOP_JOURNALRECORD DESKTOP_JOURNALPLAYBACK
                DESKTOP_ENUMERATE DESKTOP_WRITEOBJECTS DESKTOP_SWITCHDESKTOP }
            windowstation { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES
                WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP
                WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS
                WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN }
            winsta { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES
                WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP
                WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS
                WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN }
            com { COM_RIGHTS_EXECUTE COM_RIGHTS_EXECUTE_LOCAL 
                COM_RIGHTS_EXECUTE_REMOTE COM_RIGHTS_ACTIVATE_LOCAL 
                COM_RIGHTS_ACTIVATE_REMOTE 
            }
        }

        if {[min_os_version 6]} {
            dict lappend type_mask_map process PROCESS_QUERY_LIMITED_INFORMATION
        }

        if {[dict exists $type_mask_map $type]} {
            foreach x [dict get $type_mask_map $type] {
                if {$security_defs($x) & $access_mask} {
                    lappend rights [string tolower $x]
                    # Reset the bit so is it not included in unknown bits below
                    resetbits access_mask $security_defs($x)
                }
            }
        }

        # Finally add left over bits if any
        for {set i 0} {$i < 32} {incr i} {
            set x [expr {1 << $i}]
            if {$access_mask & $x} {
                lappend rights [hex32 $x]
            }
        }

        return $rights
    }

    return [_access_mask_to_rights $access_mask $type]
}

# Map the symbolic CreateDisposition parameter of CreateFile to integer values
proc twapi::_create_disposition_to_code {sym} {
    if {[string is integer -strict $sym]} {
        return $sym
    }
    # CREATE_NEW          1
    # CREATE_ALWAYS       2
    # OPEN_EXISTING       3
    # OPEN_ALWAYS         4
    # TRUNCATE_EXISTING   5
    return [dict get {
        create_new 1
        create_always 2
        open_existing 3
        open_always 4
        truncate_existing 5} $sym]
}

# Wrapper around CreateFile
proc twapi::create_file {path args} {
    array set opts [parseargs args {
        {access.arg {generic_read}}
        {share.arg {read write delete}}
        {inherit.bool 0}
        {secd.arg ""}
        {createdisposition.arg open_always}
        {flags.int 0}
        {templatefile.arg NULL}
    } -maxleftover 0]

    set access_mode [_access_rights_to_mask $opts(access)]
    set share_mode [_share_mode_to_mask $opts(share)]
    set create_disposition [_create_disposition_to_code $opts(createdisposition)]
    return [CreateFile $path \
                $access_mode \
                $share_mode \
                [_make_secattr $opts(secd) $opts(inherit)] \
                $create_disposition \
                $opts(flags) \
                $opts(templatefile)]
}

# Map a set of share mode symbols to a flag. Concatenates
# all the arguments, and then OR's the individual elements. Each
# element may either be a integer or one of the share modes
proc twapi::_share_mode_to_mask {modelist} {
    # Values correspond to FILE_SHARE_* defines
    return [_parse_symbolic_bitmask $modelist {read 1 write 2 delete 4}]
}

# Construct a security attributes structure out of a security descriptor
# and inheritance. The command is here because we do not want to
# have to load the twapi_security package for the common case of
# null security attributes.
proc twapi::_make_secattr {secd inherit} {
    if {$inherit} {
        set sec_attr [list $secd 1]
    } else {
        if {[llength $secd] == 0} {
            # If a security descriptor not specified, keep
            # all security attributes as an empty list (ie. NULL)
            set sec_attr [list ]
        } else {
            set sec_attr [list $secd 0]
        }
    }
    return $sec_attr
}

# Returns the sid, domain and type for an account
proc twapi::lookup_account_name {name args} {
    variable _name_to_sid_cache

    # Fast path - no options specified and cached
    if {[llength $args] == 0 && [dict exists $_name_to_sid_cache "" $name]} {
        return [lindex [dict get $_name_to_sid_cache "" $name] 0]
    }

    array set opts [parseargs args \
                        [list all \
                             sid \
                             domain \
                             type \
                             [list system.arg ""]\
                            ]]

    if {! [dict exists $_name_to_sid_cache $opts(system) $name]} {
        dict set _name_to_sid_cache $opts(system) $name [LookupAccountName $opts(system) $name]
    }    
    lassign [dict get $_name_to_sid_cache $opts(system) $name] sid domain type

    set result [list ]
    if {$opts(all) || $opts(domain)} {
        lappend result -domain $domain
    }
    if {$opts(all) || $opts(type)} {
        if {[info exists twapi::sid_type_names($type)]} {
            lappend result -type $twapi::sid_type_names($type)
        } else {
            # Could be the "logonid" dummy type we added above
            lappend result -type $type
        }
    }

    if {$opts(all) || $opts(sid)} {
        lappend result -sid $sid
    }

    # If no options specified, only return the sid/name
    if {[llength $result] == 0} {
        return $sid
    }

    return $result
}


# Returns the name, domain and type for an account
proc twapi::lookup_account_sid {sid args} {
    variable _sid_to_name_cache

    # Fast path - no options specified and cached
    if {[llength $args] == 0 && [dict exists $_sid_to_name_cache "" $sid]} {
        return [lindex [dict get $_sid_to_name_cache "" $sid] 0]
    }

    array set opts [parseargs args \
                        [list all \
                             name \
                             domain \
                             type \
                             [list system.arg ""]\
                            ]]

    if {! [dict exists $_sid_to_name_cache $opts(system) $sid]} {
        # Not in cache. Need to look up

        # LookupAccountSid returns an error for this SID
        if {[is_valid_sid_syntax $sid] &&
            [string match -nocase "S-1-5-5-*" $sid]} {
            set name "Logon SID"
            set domain "NT AUTHORITY"
            set type "logonid"
            dict set _sid_to_name_cache $opts(system) $sid [list $name $domain $type]
        } else {
            set data [LookupAccountSid $opts(system) $sid]
            lassign $data name domain type
            dict set _sid_to_name_cache $opts(system) $sid $data
        }
    } else {
        lassign [dict get $_sid_to_name_cache $opts(system) $sid] name domain type
    }


    set result [list ]
    if {$opts(all) || $opts(domain)} {
        lappend result -domain $domain
    }
    if {$opts(all) || $opts(type)} {
        if {[info exists twapi::sid_type_names($type)]} {
            lappend result -type $twapi::sid_type_names($type)
        } else {
            # Could be the "logonid" dummy type we added above
            lappend result -type $type
        }
    }

    if {$opts(all) || $opts(name)} {
        lappend result -name $name
    }

    # If no options specified, only return the sid/name
    if {[llength $result] == 0} {
        return $name
    }

    return $result
}

# Returns the sid for a account - may be given as a SID or name
proc twapi::map_account_to_sid {account args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    # Treat empty account as null SID (self)
    if {[string length $account] == ""} {
        return ""
    }

    if {[is_valid_sid_syntax $account]} {
        return $account
    } else {
        return [lookup_account_name $account -system $opts(system)]
    }
}


# Returns the name for a account - may be given as a SID or name
proc twapi::map_account_to_name {account args} {
    array set opts [parseargs args {system.arg} -nulldefault]

    if {[is_valid_sid_syntax $account]} {
        return [lookup_account_sid $account -system $opts(system)]
    } else {
        # Verify whether a valid account by mapping to an sid
        if {[catch {map_account_to_sid $account -system $opts(system)}]} {
            # As a special case, change LocalSystem to SYSTEM. Some Windows
            # API's (such as services) return LocalSystem which cannot be
            # resolved by the security functions. This name is really the
            # same a the built-in SYSTEM
            if {$account == "LocalSystem"} {
                return "SYSTEM"
            }
            error "Unknown account '$account'"
        } 
        return $account
    }
}

# Return the user account for the current process
proc twapi::get_current_user {{format -samcompatible}} {

    set return_sid false
    switch -exact -- $format {
        -fullyqualifieddn {set format 1}
        -samcompatible {set format 2}
        -display {set format 3}
        -uniqueid {set format 6}
        -canonical {set format 7}
        -userprincipal {set format 8}
        -canonicalex {set format 9}
        -serviceprincipal {set format 10}
        -dnsdomain {set format 12}
        -sid {set format 2 ; set return_sid true}
        default {
            error "Unknown user name format '$format'"
        }
    }

    set user [GetUserNameEx $format]

    if {$return_sid} {
        return [map_account_to_sid $user]
    } else {
        return $user
    }
}

# Get a new uuid
proc twapi::new_uuid {{opt ""}} {
    if {[string length $opt]} {
        if {[string equal $opt "-localok"]} {
            set local_ok 1
        } else {
            error "Invalid or unknown argument '$opt'"
        }
    } else {
        set local_ok 0
    }
    return [UuidCreate $local_ok] 
}
proc twapi::nil_uuid {} {
    return [UuidCreateNil]
}

proc twapi::new_guid {} {
    return [canonicalize_guid [new_uuid]]
}

# Get a handle to a LSA policy. TBD - document
proc twapi::get_lsa_policy_handle {args} {
    array set opts [parseargs args {
        {system.arg ""}
        {access.arg policy_read}
    } -maxleftover 0]

    set access [_access_rights_to_mask $opts(access)]
    return [Twapi_LsaOpenPolicy $opts(system) $access]
}

# Close a LSA policy handle. TBD - document
proc twapi::close_lsa_policy_handle {h} {
    LsaClose $h
    return
}

# Eventlog stuff in the base package

namespace eval twapi {
    # Keep track of event log handles - values are "r" or "w"
    variable eventlog_handles
    array set eventlog_handles {}
}

# Open an eventlog for reading or writing
proc twapi::eventlog_open {args} {
    variable eventlog_handles

    array set opts [parseargs args {
        system.arg
        source.arg
        file.arg
        write
    } -nulldefault -maxleftover 0]
    if {$opts(source) == ""} {
        # Source not specified
        if {$opts(file) == ""} {
            # No source or file specified, default to current event log 
            # using executable name as source
            set opts(source) [file rootname [file tail [info nameofexecutable]]]
        } else {
            if {$opts(write)} {
                error "Option -file may not be used with -write"
            }
        }
    } else {
        # Source explicitly specified
        if {$opts(file) != ""} {
            error "Option -file may not be used with -source"
        }
    }

    if {$opts(write)} {
        set handle [RegisterEventSource $opts(system) $opts(source)]
        set mode write
    } else {
        if {$opts(source) != ""} {
            set handle [OpenEventLog $opts(system) $opts(source)]
        } else {
            set handle [OpenBackupEventLog $opts(system) $opts(file)]
        }
        set mode read
    }

    set eventlog_handles($handle) $mode
    return $handle
}

# Close an event log opened for writing
proc twapi::eventlog_close {hevl} {
    variable eventlog_handles

    if {[_eventlog_valid_handle $hevl read]} {
        CloseEventLog $hevl
    } else {
        DeregisterEventSource $hevl
    }

    unset eventlog_handles($hevl)
}


# Log an event
proc twapi::eventlog_write {hevl id args} {
    _eventlog_valid_handle $hevl write raise

    array set opts [parseargs args {
        {type.arg information {success error warning information auditsuccess auditfailure}}
        {category.int 1}
        loguser
        params.arg
        data.arg
    } -nulldefault]


    switch -exact -- $opts(type) {
        success          {set opts(type) 0}
        error            {set opts(type) 1}
        warning          {set opts(type) 2}
        information      {set opts(type) 4}
        auditsuccess     {set opts(type) 8}
        auditfailure     {set opts(type) 16}
        default {error "Invalid value '$opts(type)' for option -type"}
    }
    
    if {$opts(loguser)} {
        set user [get_current_user -sid]
    } else {
        set user ""
    }

    ReportEvent $hevl $opts(type) $opts(category) $id \
        $user $opts(params) $opts(data)
}


# Log a message 
proc twapi::eventlog_log {message args} {
    array set opts [parseargs args {
        system.arg
        source.arg
        {type.arg information}
        {category.int 0}
    } -nulldefault]

    set hevl [eventlog_open -write -source $opts(source) -system $opts(system)]

    trap {
        eventlog_write $hevl 1 -params [list $message] -type $opts(type) -category $opts(category)
    } finally {
        eventlog_close $hevl
    }
    return
}

proc twapi::make_logon_identity {username password domain} {
    if {[concealed? $password]} {
        return [list $username $domain $password]
    } else {
        return [list $username $domain [conceal $password]]
    }
}

proc twapi::read_credentials {args} {
    array set opts [parseargs args {
        target.arg
        winerror.int
        username.arg
        password.arg
        persist.bool
        {type.sym generic {domain 0 generic 0x40000 runas 0x80000}}
        {forceui.bool 0 0x80}
        {showsaveoption.bool true}
        {expectconfirmation.bool 0 0x20000}
    } -maxleftover 0 -nulldefault]

    if {$opts(persist) && ! $opts(expectconfirmation)} {
        badargs! "Option -expectconfirmation must be specified as true if -persist is true"
    }

    # 0x8 -> CREDUI_FLAGS_EXCLUDE_CERTIFICATES (needed for console)
    set flags [expr {0x8 | $opts(forceui) | $opts(expectconfirmation)}]

    if {$opts(persist)} {
        if {! $opts(showsaveoption)} {
            incr flags 0x1000;  # CREDUI_FLAGS_PERSIST
        }
    } else {
        incr flags 0x2;         # CREDUI_FLAGS_DO_NOT_PERSIST
        if {$opts(showsaveoption)} {
            incr flags 0x40;    # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX
        }
    }

    incr flags $opts(type)

    return [CredUICmdLinePromptForCredentials $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags]
}

# Prompt for a password at the console
proc twapi::credentials_dialog {args} {
    array set opts [parseargs args {
        target.arg
        winerror.int
        username.arg
        password.arg
        persist.bool
        {type.sym generic {domain 0 generic 0x40000 runas 0x80000}}
        {forceui.bool 0 0x80}
        {showsaveoption.bool true}
        {expectconfirmation.bool 0 0x20000}
        {fillusername.bool 0 0x800}
        {filllocaladmins.bool 0 0x4}
        {notifyfail.bool 0 0x1}
        {passwordonly.bool 0 0x200}
        {requirecertificate.bool 0 0x10}
        {requiresmartcard.bool 0 0x100}
        {validateusername.bool 0 0x400}
        {parent.arg NULL}
        message.arg
        caption.arg
        {bitmap.arg NULL}
    } -maxleftover 0 -nulldefault]

    if {$opts(persist) && ! $opts(expectconfirmation)} {
        badargs! "Option -willconfirm must be specified as true if -persist is true"
    }

    set flags [expr { 0x8 | $opts(forceui) | $opts(notifyfail) | $opts(expectconfirmation) | $opts(fillusername) | $opts(filllocaladmins)}]

    if {$opts(persist)} {
        if {! $opts(showsaveoption)} {
            incr flags 0x1000;  # CREDUI_FLAGS_PERSIST
        }
    } else {
        incr flags 0x2;         # CREDUI_FLAGS_DO_NOT_PERSIST
        if {$opts(showsaveoption)} {
            incr flags 0x40;    # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX
        }
    }

    incr flags $opts(type)

    return [CredUIPromptForCredentials [list $opts(parent) $opts(message) $opts(caption) $opts(bitmap)] $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags]
}

proc twapi::confirm_credentials {target valid} {
    return [CredUIConfirmCredential $target $valid]
}

# Validate a handle for a mode. Always raises error if handle is invalid
# If handle valid but not for that mode, will raise error iff $raise_error
# is non-empty. Returns 1 if valid, 0 otherwise
proc twapi::_eventlog_valid_handle {hevl mode {raise_error ""}} {
    variable eventlog_handles
    if {![info exists eventlog_handles($hevl)]} {
        error "Invalid event log handle '$hevl'"
    }

    if {[string compare $eventlog_handles($hevl) $mode]} {
        if {$raise_error != ""} {
            error "Eventlog handle '$hevl' not valid for $mode"
        }
        return 0
    } else {
        return 1
    }
}

### Common disk related

# Map bit mask to list of drive letters
proc twapi::_drivemask_to_drivelist {drivebits} {
    set drives [list ]
    set i 0
    foreach drive {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} {
        if {$drivebits == 0} break
        set drivemask [expr {1 << $i}]
        if {[expr {$drivebits & $drivemask}]} {
            lappend drives $drive:
            set drivebits [expr {$drivebits & ~ $drivemask}]
        }
        incr i
    }
    return $drives
}

### Type casts
proc twapi::tclcast {type val} {
    # Only permit these because wideInt, for example, cannot be reliably
    # converted -> it can return an int instead.
    set types {"" empty null int boolean double string list dict}
    if {$type ni $types} {
        badargs! "Bad cast to \"$type\". Must be one of: $types"
    }
    return [Twapi_InternalCast $type $val]
}

if {[info commands ::lmap] eq "::lmap"} {
    proc twapi::safearray {type l} {
        set type [dict! {
            variant ""
            boolean boolean
            bool boolean
            int  int
            i4   int
            double double
            r8   double
            string string
            bstr string
        } $type]
        return [lmap val $l {tclcast $type $val}]
    }
} else {
    proc twapi::safearray {type l} {
        set type [dict! {
            variant ""
            boolean boolean
            bool boolean
            int  int
            i4   int
            double double
            r8   double
            string string
            bstr string
        } $type]
        set l2 {}
        foreach val $l {
            lappend l2 [tclcast $type $val]
        }
        return $l2
    }
}

namespace eval twapi::recordarray {}

proc twapi::recordarray::size {ra} {
    return [llength [lindex $ra 1]]
}

proc twapi::recordarray::fields {ra} {
    return [lindex $ra 0]
}

proc twapi::recordarray::index {ra row args} {
    set r [lindex $ra 1 $row]
    if {[llength $r] == 0} {
        return $r
    }
    ::twapi::parseargs args {
        {format.arg list {list dict}}
        slice.arg
    } -setvars -maxleftover 0

    set fields [lindex $ra 0]
    if {[info exists slice]} {
        set new_fields {}        
        set new_r {}
        foreach field $slice {
            set i [twapi::enum $fields $field]
            lappend new_r [lindex $r $i]
            lappend new_fields [lindex $fields $i]
        }
        set r $new_r
        set fields $new_fields
    }

    if {$format eq "list"} {
        return $r
    } else {
        return [::twapi::twine $fields $r]
    }
}

proc twapi::recordarray::range {ra low high} {
    return [list [lindex $ra 0] [lrange [lindex $ra 1] $low $high]]
}

proc twapi::recordarray::column {ra field args} {
    # TBD - time to see if a script loop would be faster
    ::twapi::parseargs args {
        filter.arg
    } -nulldefault -maxleftover 0 -setvars
    _recordarray -slice [list $field] -filter $filter -format flat $ra
}

proc twapi::recordarray::cell {ra row field} {
    return [lindex [lindex $ra 1 $row] [twapi::enum [lindex $ra 0] $field]]
}

proc twapi::recordarray::get {ra args} {
    ::twapi::parseargs args {
        {format.arg list {list dict flat}}
        key.arg
    } -ignoreunknown -setvars

    # format & key are options just to stop them flowing down to _recordarray
    # We do not pass it in

    return [_recordarray {*}$args $ra]
}

proc twapi::recordarray::getlist {ra args} {
    # key is an option just to stop in flowing down to _recordarray
    # We do not pass it in

    if {[llength $args] == 0} {
        return [lindex $ra 1]
    }

    ::twapi::parseargs args {
        {format.arg list {list dict flat}}
        key.arg
    } -ignoreunknown -setvars


    return [_recordarray {*}$args -format $format $ra]
}

proc twapi::recordarray::getdict {ra args} {
    ::twapi::parseargs args {
        {format.arg list {list dict}}
        key.arg
    } -ignoreunknown -setvars

    if {![info exists key]} {
        set key [lindex $ra 0 0]
    }

    # Note _recordarray has different (putting it politely) semantics
    # of how -format and -key option are handled so the below might
    # look a bit strange in that we pass -format as list and get
    # back a dict
    return [_recordarray {*}$args -format $format -key $key $ra]
}

proc twapi::recordarray::iterate {arrayvarname ra args} {

    if {[llength $args] == 0} {
        badargs! "No script supplied"
    }

    set body [lindex $args end]
    set args [lrange $args 0 end-1]

    upvar 1 $arrayvarname var

    # TBD - Can this be optimized by prepending a ::foreach to body
    # and executing that in uplevel 1 ?

    foreach rec [getlist $ra {*}$args -format dict] {
        array set var $rec
        set code [catch {uplevel 1 $body} result]
        switch -exact -- $code {
            0 {}
            1 {
                return -errorinfo $::errorInfo -errorcode $::errorCode -code error $result
            }
            3 {
                return;          # break
            }
            4 {
                # continue
            }
            default {
                return -code $code $result
            }
        }
    }
    return
}

proc twapi::recordarray::rename {ra renames} {
    set new_fields {}
    foreach field [lindex $ra 0] {
        if {[dict exists $renames $field]} {
            lappend new_fields [dict get $renames $field]
        } else {
            lappend new_fields $field
        }
    }
    return [list $new_fields [lindex $ra 1]]
}

proc twapi::recordarray::concat {args} {
    if {[llength $args] == 0} {
        return {}
    }
    set args [lassign $args ra]
    set fields [lindex $ra 0]
    set values [list [lindex $ra 1]]
    set width [llength $fields]
    foreach ra $args {
        foreach fld1 $fields fld2 [lindex $ra 0] {
            if {$fld1 ne $fld2} {
                twapi::badargs! "Attempt to concat record arrays with different fields ([join $fields ,] versus [join [lindex $ra 0] ,])"
            }
        }
        lappend values [lindex $ra 1]
    }

    return [list $fields [::twapi::lconcat {*}$values]]
}

namespace eval twapi::recordarray {
    namespace export cell column concat fields get getdict getlist index iterate range rename size
    namespace ensemble create
}

# Return a suitable cstruct definition based on a C definition
proc twapi::struct {struct_name s} {
    variable _struct_defs

    regsub -all {(/\*.* \*/){1,1}?} $s {} s
    regsub -line -all {//.*$} $s { } s
    set l {}
    foreach def [split $s ";"] {
        set def [string trim $def]
        if {$def eq ""} continue
        if {![regexp {^(.+[^[:alnum:]_])([[:alnum:]_]+)\s*(\[.+\])?$} $def ->  type name array]} {
            error "Invalid definition $def"
        }
        
        set child {}
        switch -regexp -matchvar matchvar -- [string trim $type] {
            {^char$} {set type i1}
            {^BYTE$} -
            {^unsigned char$} {set type ui1}
            {^short$} {set type i2}
            {^WORD$} -
            {^unsigned\s+short$} {set type ui2}
            {^BOOLEAN$} {set type bool}
            {^LONG$} -
            {^int$} {set type i4}
            {^UINT$} -
            {^ULONG$} -
            {^DWORD$} -
            {^unsigned\s+int$} {set type ui4}
            {^__int64$} {set type i8}
            {^unsigned\s+__int64$} {set type ui8}
            {^double$} {set type r8}
            {^LPCSTR$} -
            {^LPSTR$} -
            {^char\s*\*$} {set type lpstr}
            {^LPCWSTR$} -
            {^LPWSTR$} -
            {^WCHAR\s*\*$} {set type lpwstr}
            {^HANDLE$} {set type handle}
            {^PSID$} {set type psid}
            {^struct\s+([[:alnum:]_]+)$} {
                # Embedded struct. It should be defined already. Calling
                # it with no args returns its definition but doing that
                # to retrieve the definition could be a security hole
                # (could be passed any Tcl command!) if unwary apps
                # pass in input from unknown sources. So we explicitly
                # remember definitions instead.
                set child_name [lindex $matchvar 1]
                if {![info exists _struct_defs($child_name)]} {
                    error "Unknown struct $child_name"
                }
                set child $_struct_defs($child_name)
                set type struct
            }
            default {error "Unknown type $type"}
        }
        set count 0
        if {$array ne ""} {
            set count [string trim [string range $array 1 end-1]]
            if {![string is integer -strict $count]} {
                error "Non-integer array size"
            }
        }

        if {[string equal -nocase $name "cbSize"] &&
            $type in {i4 ui4} && $count == 0} {
            set type cbsize
        }

        lappend l [list $name $type $count $child]
    }

    set proc_body [format {
        set def %s
        if {[llength $args] == 0} {
            return $def
        } else {
            return [list $def $args]
        }
    } [list $l]]
    uplevel 1 [list proc $struct_name args $proc_body]
    set _struct_defs($struct_name) $l
    return
}

#
# 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
}

# Read data from the clipboard
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
}

# Read text data from the clipboard
proc twapi::read_clipboard_text {args} {
    array set opts [parseargs args {
        {raw.bool 0}
    }]

    trap {
        set h [GetClipboardData 13];    # 13 -> Unicode
        set p [GlobalLock $h]
        # Read data discarding terminating null
        set data [Twapi_ReadMemory 3 $p 0 [GlobalSize $h] 1]
        if {! $opts(raw)} {
            set data [string map {"\r\n" "\n"} $data]
        }
    } onerror {} {
        catch {close_clipboard}
        rethrow
    } finally {
        if {[info exists p]} {
            GlobalUnlock $h
        }
    }

    return $data
}

# Write data to the clipboard
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
}

# Write text to the clipboard
proc twapi::write_clipboard_text {data args} {
    array set opts [parseargs args {
        {raw.bool 0}
    }]

    # Always catch errors and close
    # clipboard before passing exception on
    trap {
        # 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]
        }
                  
        set mem_size [expr {2*(1+[string length $data])}]

        # Allocate global memory
        set mem_h [GlobalAlloc 2 $mem_size]
        set mem_p [GlobalLock $mem_h]

        # 3 -> write memory as Unicode
        Twapi_WriteMemory 3 $mem_p 0 $mem_size $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_h mem_p
        GlobalUnlock $h
        SetClipboardData 13 $h;         # 13 -> Unicode format
    } onerror {} {
        catch {close_clipboard}
        rethrow
    } finally {
        if {[info exists mem_p]} {
            GlobalUnlock $mem_h
        }
        if {[info exists mem_h]} {
            GlobalFree $mem_h
        }
    }
    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]
}



# Start monitoring of the clipboard
proc twapi::_clipboard_handler {} {
    variable _clipboard_monitors

    if {![info exists _clipboard_monitors] ||
        [llength $_clipboard_monitors] == 0} {
        return; # Not an error, could have deleted while already queued
    }

    foreach {id script} $_clipboard_monitors {
        set code [catch {uplevel #0 $script} msg]
        if {$code == 1} {
            # Error - put in background but we do not abort
            after 0 [list error $msg $::errorInfo $::errorCode]
        }
    }
    return
}

proc twapi::start_clipboard_monitor {script} {
    variable _clipboard_monitors

    set id "clip#[TwapiId]"
    if {![info exists _clipboard_monitors] ||
        [llength $_clipboard_monitors] == 0} {
        # No clipboard monitoring in progress. Start it
        Twapi_ClipboardMonitorStart
    }

    lappend _clipboard_monitors $id $script
    return $id
}



# Stop monitoring of the clipboard
proc twapi::stop_clipboard_monitor {clipid} {
    variable _clipboard_monitors

    if {![info exists _clipboard_monitors]} {
        return;                 # Should we raise an error instead?
    }

    set new_monitors {}
    foreach {id script} $_clipboard_monitors {
        if {$id ne $clipid} {
            lappend new_monitors $id $script
        }
    }

    set _clipboard_monitors $new_monitors
    if {[llength $_clipboard_monitors] == 0} {
        Twapi_ClipboardMonitorStop
    }
}

#
# Copyright (c) 2006-2014 Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# TBD - tests  comobj? works with derived classes of Automation
# TBD - document and test -iterate -cleanup option

# TBD - object identity comparison 
#   - see http://blogs.msdn.com/ericlippert/archive/2005/04/26/412199.aspx
# TBD - we seem to resolve UDT's every time a COM method is actually invoked.
# Optimize by doing it when prototype is stored or only the first time it
# is called.
# TBD - optimize by caching UDT's within a type library when the library
# is read.

namespace eval twapi {
    # Maps TYPEKIND data values to symbols
    variable _typekind_map
    array set _typekind_map {
        0 enum
        1 record
        2 module
        3 interface
        4 dispatch
        5 coclass
        6 alias
        7 union
    }

    # Cache of Interface names - IID mappings
    variable _name_to_iid_cache
    array set _name_to_iid_cache {
        iunknown  {{00000000-0000-0000-C000-000000000046}}
        idispatch {{00020400-0000-0000-C000-000000000046}}
        idispatchex {{A6EF9860-C720-11D0-9337-00A0C90DCAA9}}
        itypeinfo {{00020401-0000-0000-C000-000000000046}}
        itypecomp {{00020403-0000-0000-C000-000000000046}}
        ienumvariant {{00020404-0000-0000-C000-000000000046}}
        iprovideclassinfo {{B196B283-BAB4-101A-B69C-00AA00341D07}}

        ipersist  {{0000010c-0000-0000-C000-000000000046}}
        ipersistfile {{0000010b-0000-0000-C000-000000000046}}

        iprovidetaskpage {{4086658a-cbbb-11cf-b604-00c04fd8d565}}
        itasktrigger {{148BD52B-A2AB-11CE-B11F-00AA00530503}}
        ischeduleworkitem {{a6b952f0-a4b1-11d0-997d-00aa006887ec}}
        itask {{148BD524-A2AB-11CE-B11F-00AA00530503}}
        ienumworkitems {{148BD528-A2AB-11CE-B11F-00AA00530503}}
        itaskscheduler {{148BD527-A2AB-11CE-B11F-00AA00530503}}
        imofcompiler {{6daf974e-2e37-11d2-aec9-00c04fb68820}}
    }
}

proc twapi::IUnknown_QueryInterface {ifc iid} {
    set iidname void
    catch {set iidname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]}
    return [Twapi_IUnknown_QueryInterface $ifc $iid $iidname]
}

proc twapi::CoGetObject {name bindopts iid} {
    set iidname void
    catch {set iidname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]}
    return [Twapi_CoGetObject $name $bindopts $iid $iidname]
}

proc twapi::progid_to_clsid {progid} { return [CLSIDFromProgID $progid] }
proc twapi::clsid_to_progid {progid} { return [ProgIDFromCLSID $progid] }

proc twapi::com_security_blanket {args} {
    # mutualauth.bool - docs for EOLE_AUTHENTICATION_CAPABILITIES. Learning
    # DCOM says it is only for CoInitializeSecurity. Either way, 
    # that option is not applicable here
    parseargs args {
        {authenticationservice.arg default}
        serverprincipal.arg
        {authenticationlevel.arg default}
        {impersonationlevel.arg default}
        credentials.arg
        cloaking.arg
    } -maxleftover 0 -setvars

    set authenticationservice [_com_name_to_authsvc $authenticationservice]
    set authenticationlevel [_com_name_to_authlevel $authenticationlevel]
    set impersonationlevel [_com_name_to_impersonation $impersonationlevel]

    if {![info exists cloaking]} {
        set eoac 0x800;         # EOAC_DEFAULT
    } else {
        set eoac [dict! {none 0 static 0x20 dynamic 0x40} $cloaking]
    }

    if {[info exists credentials]} {
        # Credentials specified. Empty list -> NULL, ie use thread token
        set creds_tag 1
    } else {
        # Credentials not to be changed
        set creds_tag 0
        set credentials {};     # Ignored
    }

    if {[info exists serverprincipal]} {
        if {$serverprincipal eq ""} {
            set serverprincipaltag 0; # Default based on com_initialize_security
        } else {
            set serverprincipaltag 2
        }
    } else {
        set serverprincipaltag 1; # Unchanged server principal
        set serverprincipal ""
    }

    return [list $authenticationservice 0 $serverprincipaltag $serverprincipal $authenticationlevel $impersonationlevel $creds_tag $credentials $eoac]
}

# TBD - document
proc twapi::com_query_client_blanket {} {
    lassign [CoQueryClientBlanket] authn authz server authlevel implevel client capabilities
    if {$capabilities & 0x20} {
        # EOAC_STATIC_CLOAKING
        set cloaking static
    } elseif {$capabilities & 0x40} {
        set cloaking dynamic
    } else {
        set cloaking none
    }

    # Note there is no implevel set as CoQueryClientBlanket does
    # not return that information and implevel is a dummy value
    return [list \
                -authenticationservice [_com_authsvc_to_name $authn] \
                -authorizationservice [dict* {0 none 1 name 2 dce} $authz] \
                -serverprincipal $server \
                -authenticationlevel [_com_authlevel_to_name $authlevel] \
                -clientprincipal $client \
                -cloaking $cloaking \
               ]
}

# TBD - document
proc twapi::com_query_proxy_blanket {ifc} {
    lassign [CoQueryProxyBlanket [lindex $args 0]] authn authz server authlevel implevel client capabilities
    if {$capabilities & 0x20} {
        # EOAC_STATIC_CLOAKING
        set cloaking static
    } elseif {$capabilities & 0x40} {
        set cloaking dynamic
    } else {
        set cloaking none
    }

    return [list \
                -authenticationservice [_com_authsvc_to_name $authn] \
                -authorizationservice [dict* {0 none 1 name 2 dce} $authz] \
                -serverprincipal $server \
                -authenticationlevel [_com_authlevel_to_name $authlevel] \
                -impersonationlevel [_com_impersonation_to_name $implevel] \
                -clientprincipal $client \
                -cloaking $cloaking \
               ]
            
}

# TBD - document
proc twapi::com_initialize_security {args} {
    # TBD - mutualauth?
    # TBD - securerefs?
    parseargs args {
        {authenticationlevel.arg default}
        {impersonationlevel.arg impersonate}
        {cloaking.sym none {none 0 static 0x20 dynamic 0x40}}
        secd.arg
        appid.arg
        authenticationservices.arg
    } -maxleftover 0 -setvars
    
    if {[info exists secd] && [info exists appid]} {
        badargs! "Only one of -secd and -appid can be specified."
    }

    set impersonationlevel [_com_name_to_impersonation $impersonationlevel]
    set authenticationlevel [_com_name_to_authlevel $authenticationlevel]

    set eoac $cloaking
    if {[info exists appid]} {
        incr eoac 8;     # 8 -> EOAC_APPID
        set secarg $appid
    } else {
        if {[info exists secd]} {
            set secarg $secd
        } else {
            set secarg {}
        }
    }

    set authlist {}
    if {[info exists authenticationservices]} {
        foreach authsvc $authenticationservices {
            lappend authlist [list [_com_name_to_authsvc [lindex $authsvc 0]] 0 [lindex $authsvc 1]]
        }
    }

    CoInitializeSecurity $secarg "" "" $authenticationlevel $impersonationlevel $authlist $eoac ""
}

interp alias {} twapi::com_make_credentials {} twapi::make_logon_identity

# TBD - document
proc twapi::com_create_instance {clsid args} {
    array set opts [parseargs args {
        {model.arg any}
        download.bool
        {disablelog.bool false}
        enableaaa.bool
        {nocustommarshal.bool false 0x1000}
        {interface.arg IUnknown}
        {authenticationservice.arg none}
        {impersonationlevel.arg impersonate}
        {credentials.arg {}}
        {serverprincipal.arg {}}
        {authenticationlevel.arg default}
        {mutualauth.bool 0 0x1}
        securityblanket.arg
        system.arg
        raw
    } -maxleftover 0]

    set opts(authenticationservice) [_com_name_to_authsvc $opts(authenticationservice)]
    set opts(authenticationlevel) [_com_name_to_authlevel $opts(authenticationlevel)]
    set opts(impersonationlevel) [_com_name_to_impersonation $opts(impersonationlevel)]

    # CLSCTX_NO_CUSTOM_MARSHAL ?
    set flags $opts(nocustommarshal)

    set model 0
    if {[info exists opts(model)]} {
        foreach m $opts(model) {
            switch -exact -- $m {
                any           {setbits model 23}
                inprocserver  {setbits model 1}
                inprochandler {setbits model 2}
                localserver   {setbits model 4}
                remoteserver  {setbits model 16}
            }
        }
    }

    setbits flags $model

    if {[info exists opts(download)]} {
        if {$opts(download)} {
            setbits flags 0x2000;       # CLSCTX_ENABLE_CODE_DOWNLOAD
        } else {
            setbits flags 0x400;       # CLSCTX_NO_CODE_DOWNLOAD
        }
    }

    if {$opts(disablelog)} {
        setbits flags 0x4000;           # CLSCTX_NO_FAILURE_LOG
    }

    if {[info exists opts(enableaaa)]} {
        if {$opts(enableaaa)} {
            setbits flags 0x10000;       # CLSCTX_ENABLE_AAA
        } else {
            setbits flags 0x8000;       # CLSCTX_DISABLE_AAA
        }
    }

    if {[info exists opts(system)]} {
        set coserverinfo [list 0 $opts(system) \
                              [list $opts(authenticationservice) \
                                   0 \
                                   $opts(serverprincipal) \
                                   $opts(authenticationlevel) \
                                   $opts(impersonationlevel) \
                                   $opts(credentials) \
                                   $opts(mutualauth) \
                                   ] \
                              0]
        set activation_blanket \
            [com_security_blanket \
                 -authenticationservice $opts(authenticationservice) \
                 -serverprincipal $opts(serverprincipal) \
                 -authenticationlevel $opts(authenticationlevel) \
                 -impersonationlevel $opts(impersonationlevel) \
                 -credentials $opts(credentials)]
    } else {
        set coserverinfo {}
    }

    # If remote, set the specified security blanket on the proxy. Note
    # that the blanket settings passed to CoCreateInstanceEx are used
    # only for activation and do NOT get passed down to method calls
    # If a remote component is activated with specific identity, we
    # assume method calls require the same security settings.

    if {([info exists activation_blanket] || [llength $opts(credentials)]) &&
        ![info exists opts(securityblanket)]} {
        if {[info exists activation_blanket]} {
            set opts(securityblanket) $activation_blanket
        } else {
            set opts(securityblanket) [com_security_blanket -credentials $opts(credentials)]
        }
    }

    lassign [_resolve_iid $opts(interface)] iid iid_name

    # TBD - is all this OleRun still necessary or is there a check we can make
    # before going down that path ?
    # Microsoft Office (and maybe others) have some, uhhm, quirks.
    # If they are loaded as inproc, all calls to retrieve an interface other 
    # than IUnknown fails. We have to get the IUnknown interface,
    # call OleRun and then retrieve the desired interface.
    # This does not happen if the localserver model was requested.
    # We could check for a specific error code but no guarantee that
    # the error is same in all versions so we catch and retry on all errors.
    # 3rd element of each sublist is status. Non-0 -> Failure code
    if {[catch {set ifcs [CoCreateInstanceEx $clsid NULL $flags $coserverinfo [list $iid]]}] || [lindex $ifcs 0 2] != 0} {
        # Try through IUnknown
        set ifcs [CoCreateInstanceEx $clsid NULL $flags $coserverinfo [list [_iid_iunknown]]]

        if {[lindex $ifcs 0 2] != 0} {
            win32_error [lindex $ifcs 0 2]
        }
        set iunk [lindex $ifcs 0 1]

        # Need to set security blanket if specified before invoking any method
        # else will get access denied
        if {[info exists opts(securityblanket)]} {
            trap {
                CoSetProxyBlanket $iunk {*}$opts(securityblanket)
            } onerror {} {
                IUnknown_Release $iunk
                rethrow
            }
        }

        trap {
            # Wait for it to run, then get desired interface from it
            twapi::OleRun $iunk
            set ifc [Twapi_IUnknown_QueryInterface $iunk $iid $iid_name]
        } finally {
            IUnknown_Release $iunk
        }
    } else {
        set ifc [lindex $ifcs 0 1]
    }

    # All interfaces are returned typed as IUnknown by the C level
    # even though they are actually the requested type.
    set ifc [cast_handle $ifc $iid_name]

    if {[info exists activation_blanket]} {
        # In order for servers to release objects properly, the IUnknown 
        # interface must have the same security settings as were used in 
        # the object creation
        _com_set_iunknown_proxy $ifc $activation_blanket
    }

    if {$opts(raw)} {
        if {[info exists opts(securityblanket)]} {
            trap {
                CoSetProxyBlanket $ifc {*}$opts(securityblanket)
            } onerror {} {
                IUnknown_Release $ifc
                rethrow
            }
        }
        return $ifc
    } else {
        set proxy [make_interface_proxy $ifc]
        if {[info exists opts(securityblanket)]} {
            trap {
                $proxy @SetSecurityBlanket $opts(securityblanket)
            } onerror {} {
                catch {$proxy Release}
                rethrow
            }
        }
        return $proxy
    }
}


proc twapi::comobj_idispatch {ifc {addref 0} {objclsid ""} {lcid 0}} {
    if {[pointer_null? $ifc]} {
        return ::twapi::comobj_null
    }

    if {[pointer? $ifc IDispatch]} {
        if {$addref} { IUnknown_AddRef $ifc }
        set proxyobj [IDispatchProxy new $ifc $objclsid]
    } elseif {[pointer? $ifc IDispatchEx]} {
        if {$addref} { IUnknown_AddRef $ifc }
        set proxyobj [IDispatchExProxy new $ifc $objclsid]
    } else {
        error "'$ifc' does not reference an IDispatch interface"
    }

    return [Automation new $proxyobj $lcid]
}

#
# Create an object command for a COM object from a name
proc twapi::comobj_object {path args} {
    array set opts [parseargs args {
        progid.arg
        {interface.arg IDispatch {IDispatch IDispatchEx}}
        {lcid.int 0}
    } -maxleftover 0]

    set clsid ""
    if {[info exists opts(progid)]} {
        # TBD - document once we have a test case for this
        # Specify which app to use to open the file.
        # See "Mapping Visual Basic to Automation" in SDK help
        set clsid [_convert_to_clsid $opts(progid)]
        set ipersistfile [com_create_instance $clsid -interface IPersistFile]
        trap {
            IPersistFile_Load $ipersistfile $path 0
            set idisp [Twapi_IUnknown_QueryInterface $ipersistfile [_iid_idispatch] IDispatch]
        } finally {
            IUnknown_Release $ipersistfile
        }
    } else {
        # TBD - can we get the CLSID for this case
        set idisp [::twapi::Twapi_CoGetObject $path {} [name_to_iid $opts(interface)] $opts(interface)]
    }

    return [comobj_idispatch $idisp 0 $clsid $opts(lcid)]
}

#
# Create a object command for a COM object IDispatch interface
# comid is either a CLSID or a PROGID
proc twapi::comobj {comid args} {
    array set opts [parseargs args {
        {interface.arg IDispatch {IDispatch IDispatchEx}}
        active
        {lcid.int 0}
    } -ignoreunknown]
    set clsid [_convert_to_clsid $comid]
    if {$opts(active)} {
        set iunk [GetActiveObject $clsid]
        twapi::trap {
            # TBD - do we need to deal with security blanket here? How do
            # know what blanket is to be used on an already active object?
            # Get the IDispatch interface
            set idisp [IUnknown_QueryInterface $iunk {{00020400-0000-0000-C000-000000000046}}]
            return [comobj_idispatch $idisp 0 $clsid $opts(lcid)]
        } finally {
            IUnknown_Release $iunk
        }
    } else {
        set proxy [com_create_instance $clsid -interface $opts(interface) {*}$args]
        $proxy @SetCLSID $clsid
        return [Automation new $proxy $opts(lcid)]
    }
}

proc twapi::comobj_destroy args {
    foreach arg $args {
        catch {$arg -destroy}
    }
}

# Return an interface to a typelib
# TBD - document
proc twapi::ITypeLibProxy_from_path {path args} {
    array set opts [parseargs args {
        {registration.arg none {none register default}}
    } -maxleftover 0]

    return [make_interface_proxy [LoadTypeLibEx $path [kl_get {default 0 register 1 none 2} $opts(registration) $opts(registration)]]]
}

#
# Return an interface to a typelib from the registry
# TBD - document
proc twapi::ITypeLibProxy_from_guid {uuid major minor args} {
    array set opts [parseargs args {
        lcid.int
    } -maxleftover 0 -nulldefault]
    
    return [make_interface_proxy [LoadRegTypeLib $uuid $major $minor $opts(lcid)]]
}

#
# Unregister a typelib
proc twapi::unregister_typelib {uuid major minor args} {
    array set opts [parseargs args {
        lcid.int
    } -maxleftover 0 -nulldefault]

    UnRegisterTypeLib $uuid $major $minor $opts(lcid) 1
}

#
# Returns the path to the typelib based on a guid
proc twapi::get_typelib_path_from_guid {guid major minor args} {
    array set opts [parseargs args {
        lcid.int
    } -maxleftover 0 -nulldefault]


    set path [variant_value [QueryPathOfRegTypeLib $guid $major $minor $opts(lcid)] 0 0 $opts(lcid)]
    # At least some versions have a bug in that there is an extra \0
    # at the end.
    if {[string equal [string index $path end] \0]} {
        set path [string range $path 0 end-1]
    }
    return $path
}

#
# Map interface name to IID
proc twapi::name_to_iid {iname} {
    set iname [string tolower $iname]

    if {[info exists ::twapi::_name_to_iid_cache($iname)]} {
        return $::twapi::_name_to_iid_cache($iname)
    }

    # Look up the registry
    set iids {}
    foreach iid [registry keys HKEY_CLASSES_ROOT\\Interface] {
        if {![catch {
            set val [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]
        }]} {
            if {[string equal -nocase $iname $val]} {
                lappend iids $iid
            }
        }
    }

    if {[llength $iids] == 1} {
        return [set ::twapi::_name_to_iid_cache($iname) [lindex $iids 0]]
    } elseif {[llength $iids]} {
        error "Multiple interfaces found matching name $iname: [join $iids ,]"
    } else {
        return [set ::twapi::_name_to_iid_cache($iname) ""]
    }
}


#
# Map interface IID to name
proc twapi::iid_to_name {iid} {
    set iname ""
    catch {set iname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]}
    return $iname
}

#
# Convert a variant time to a time list
proc twapi::variant_time_to_timelist {double} {
    return [VariantTimeToSystemTime $double]
}

#
# Convert a time list time to a variant time
proc twapi::timelist_to_variant_time {timelist} {
    return [SystemTimeToVariantTime $timelist]
}


proc twapi::typelib_print {path args} {
    array set opts [parseargs args {
        type.arg
        name.arg
        output.arg
    } -maxleftover 0 -nulldefault]

    
    if {$opts(output) ne ""} {
        if {[file exists $opts(output)]} {
            error "File $opts(output) already exists."
        }
        set outfd [open $opts(output) a]
    } else {
        set outfd stdout
    }

    trap {
        set tl [ITypeLibProxy_from_path $path -registration none]
        puts $outfd [$tl @Text -type $opts(type) -name $opts(name)]
    } finally {
        if {[info exists tl]} {
            $tl Release
        }
        if {$outfd ne "stdout"} {
            close $outfd
        }
    }        

    return
}

proc twapi::generate_code_from_typelib {path args} {
    array set opts [parseargs args {
        output.arg
    } -ignoreunknown]

    if {[info exists opts(output)]} {
        if {$opts(output) ne "stdout"} {
            if {[file exists $opts(output)]} {
                error "File $opts(output) already exists."
            }
            set outfd [open $opts(output) a]
        } else {
            set outfd stdout
        }
    }

    trap {
        set tl [ITypeLibProxy_from_path $path -registration none]
        set code [$tl @GenerateCode {*}$args]
        if {[info exists outfd]} {
            puts $outfd "package require twapi_com"
            puts $outfd $code
            return
        } else {
            return $code
        }
    } finally {
        if {[info exists tl]} {
            $tl Release
        }
        if {[info exists outfd] && $outfd ne "stdout"} {
            close $outfd
        }
    }        
}




proc twapi::_interface_text {ti} {
    # ti must be TypeInfo for an interface or module (or enum?) - TBD
    set desc ""
    array set attrs [$ti @GetTypeAttr -all]
    set desc "Functions:\n"
    for {set j 0} {$j < $attrs(-fncount)} {incr j} {
        array set funcdata [$ti @GetFuncDesc $j -all]
        if {$funcdata(-funckind) eq "dispatch"} {
            set funckind "(dispid $funcdata(-memid))"
        } else {
            set funckind "(vtable $funcdata(-vtbloffset))"
        }
        append desc "\t$funckind [::twapi::_resolve_com_type_text $ti $funcdata(-datatype)] $funcdata(-name) $funcdata(-invkind) [::twapi::_resolve_com_params_text $ti $funcdata(-params) $funcdata(-paramnames)]\n"
    }
    append desc "Variables:\n"
    for {set j 0} {$j < $attrs(-varcount)} {incr j} {
        array set vardata [$ti @GetVarDesc $j -all]
        set vardesc "($vardata(-memid)) $vardata(-varkind) [::twapi::_flatten_com_type [::twapi::_resolve_com_type_text $ti $vardata(-datatype)]] $vardata(-name)"
        if {$attrs(-typekind) eq "enum" || $vardata(-varkind) eq "const"} {
            append vardesc " = $vardata(-value)"
        } else {
            append vardesc " (offset $vardata(-value))"
        }
        append desc "\t$vardesc\n"
    }
    return $desc
}

#
# Print methods in an interface, including inherited names
proc twapi::dispatch_print {di args} {
    array set opts [parseargs args {
        output.arg
    } -maxleftover 0 -nulldefault]

    if {$opts(output) ne ""} {
        if {[file exists $opts(output)]} {
            error "File $opts(output) already exists."
        }
        set outfd [open $opts(output) a]
    } else {
        set outfd stdout
    }

    trap {
        set ti [$di @GetTypeInfo]
        twapi::_dispatch_print_helper $ti $outfd
    } finally {
        if {[info exists ti]} {
            $ti Release
        }
        if {$outfd ne "stdout"} {
            close $outfd
        }
    }

    return
}

proc twapi::_dispatch_print_helper {ti outfd {names_already_done ""}} {
    set name [$ti @GetName]
    if {$name in $names_already_done} {
        # Already printed this
        return $names_already_done
    }
    lappend names_already_done $name

    # Check for dual interfaces - we want to print both vtable and disp versions
    set tilist [list $ti]
    if {![catch {set ti2 [$ti @GetRefTypeInfoFromIndex $ti -1]}]} {
        lappend tilist $ti2
    }

    trap {
        foreach tifc $tilist {
            puts $outfd $name
            puts $outfd [_interface_text $tifc]
        }
    } finally {
        if {[info exists ti2]} {
            $ti2 Release
        }
    }

    # Now get any referenced typeinfos and print them
    array set tiattrs [$ti GetTypeAttr]
    for {set j 0} {$j < $tiattrs(cImplTypes)} {incr j} {
        set ti2 [$ti @GetRefTypeInfoFromIndex $j]
        trap {
            set names_already_done [_dispatch_print_helper $ti2 $outfd $names_already_done]
        } finally {
            $ti2 Release
        }
    }

    return $names_already_done
}



#
# Resolves references to parameter definition
proc twapi::_resolve_com_params_text {ti params paramnames} {
    set result [list ]
    foreach param $params paramname $paramnames {
        set paramdesc [_flatten_com_type [_resolve_com_type_text $ti [lindex $param 0]]]
        if {[llength $param] > 1 && [llength [lindex $param 1]] > 0} {
            set paramdesc "\[[lindex $param 1]\] $paramdesc"
        }
        if {[llength $param] > 2} {
            append paramdesc " [lrange $param 2 end]"
        }
        append paramdesc " $paramname"
        lappend result $paramdesc
    }
    return "([join $result {, }])"
}

# Flattens the output of _resolve_com_type_text
proc twapi::_flatten_com_type {com_type_desc} {
    if {[llength $com_type_desc] < 2} {
        return $com_type_desc
    }

    if {[lindex $com_type_desc 0] eq "ptr"} {
        return "[_flatten_com_type [lindex $com_type_desc 1]]*"
    } else {
        return "([lindex $com_type_desc 0] [_flatten_com_type [lindex $com_type_desc 1]])"
    }
}

#
# Resolves typedefs
proc twapi::_resolve_com_type_text {ti typedesc} {
    
    switch -exact -- [lindex $typedesc 0] {
        26 -
        ptr {
            # Recurse to resolve any inner types
            set typedesc [list ptr [_resolve_com_type_text $ti [lindex $typedesc 1]]]
        }
        29 -
        userdefined {
            set hreftype [lindex $typedesc 1]
            set ti2 [$ti @GetRefTypeInfo $hreftype]
            set typedesc "[$ti2 @GetName]"
            $ti2 Release
        }
        default {
            set typedesc [_vttype_to_string $typedesc]
        }
    }

    return $typedesc
}


#
# Given a COM type descriptor, resolved all user defined types (UDT) in it
# The descriptor must be in raw form as returned by the C code
proc twapi::_resolve_comtype {ti typedesc} {
    
    if {[lindex $typedesc 0] == 26} {
        # VT_PTR - {26 INNER_TYPEDESC}
        # If pointing to a UDT, convert to appropriate base type if possible
        set inner [_resolve_comtype $ti [lindex $typedesc 1]]
        if {[lindex $inner 0] == 29} {
            # When the referenced type is a UDT (29) which is actually
            # a dispatch or other interface, replace the
            # "pointer to UDT" with VT_DISPATCH/VT_INTERFACE
            switch -exact -- [lindex $inner 1] {
                dispatch  {set typedesc [list 9]}
                interface {set typedesc [list 13]}
                default {
                    # TBD - need to decode all the other types (record etc.)
                    set typedesc [list 26 $inner]
                }
            }
        } else {
            set typedesc [list 26 $inner]
        }
    } elseif {[lindex $typedesc 0] == 29} {
        # VT_USERDEFINED - {29 HREFTYPE}
        set ti2 [$ti @GetRefTypeInfo [lindex $typedesc 1]]
        array set tattr [$ti2 @GetTypeAttr -guid -typekind]
        if {$tattr(-typekind) eq "enum"} {
            set typedesc [list 3]; # 3 -> i4
        } else {
            if {$tattr(-typekind) eq "alias"} {
                set typedesc [_resolve_comtype $ti2 [kl_get [$ti2 GetTypeAttr] tdescAlias]]
            } else {
                set typedesc [list 29 $tattr(-typekind) $tattr(-guid)]
            }
        }
        $ti2 Release
    }

    return $typedesc
}

proc twapi::_resolve_params_for_prototype {ti paramdescs} {
    set params {}
    foreach paramdesc $paramdescs {
        lappend params \
            [lreplace $paramdesc 0 0 [::twapi::_resolve_comtype $ti [lindex $paramdesc 0]]]
    }
    return $params
}

proc twapi::_variant_values_from_safearray {sa ndims {raw false} {addref false} {lcid 0}} {
    set result {}
    if {[incr ndims -1] > 0} {
	foreach elem $sa {
	    lappend result [_variant_values_from_safearray $elem $ndims $raw $addref $lcid]
	}
    } else {
	foreach elem $sa {
	    lappend result [twapi::variant_value $elem $raw $addref $lcid]
	}
    }
    return $result
}

proc twapi::outvar {varname} { return [Twapi_InternalCast outvar $varname] }

# TBD - document
# Returns a string value from a formatted variant value pair {VT_xxx value}
# $addref controls whether we do an AddRef when the value is a pointer to
# an interface. $raw controls whether interface pointers are returned
# as raw interface handles or objects.
proc twapi::variant_value {variant raw addref lcid} {
    # TBD - format appropriately depending on variant type for dates and
    # currency
    if {[llength $variant] == 0} {
        return ""
    }
    set vt [lindex $variant 0]

    if {$vt & 0x2000} {
        # VT_ARRAY - second element is {dimensions value}
        if {[llength $variant] < 2} {
            return [list ]
        }
        lassign [lindex $variant 1] dimensions values
        set vt [expr {$vt & ~ 0x2000}]
        if {$vt == 12} {
            # Array of variants. Recursively convert values
            return [_variant_values_from_safearray \
                        $values \
                        [expr {[llength $dimensions] / 2}] \
                        $raw $addref $lcid]
        } else {
            return $values
        }
    } else {
        if {$vt == 9} {
            set idisp [lindex $variant 1]; # May be NULL!
            if {$addref && ! [pointer_null? $idisp]} {
                IUnknown_AddRef $idisp
            }
            if {$raw} {
                return $idisp
            } else {
                # Note comobj_idispatch takes care of NULL
                return [comobj_idispatch $idisp 0 "" $lcid]
            }
        } elseif {$vt == 13} {
            set iunk [lindex $variant 1]; # May be NULL!
            if {$addref && ! [pointer_null? $iunk]} {
                IUnknown_AddRef $iunk
            }
            if {$raw} {
                return $iunk
            } else {
                return [make_interface_proxy $iunk]
            }
        }
    }
    return [lindex $variant 1]
}

proc twapi::variant_type {variant} {
    return [lindex $variant 0]
}

proc twapi::vt_null {} {
    return [tclcast null ""]
}

proc twapi::vt_empty {} {
    return [tclcast empty ""]
}

#
# General dispatcher for callbacks from event sinks. Invokes the actual
# registered script after mapping dispid's
proc twapi::_eventsink_callback {comobj script callee args} {
    # Check if the comobj is still active
    if {[llength [info commands $comobj]] == 0} {
        if {$::twapi::log_config(twapi_com)} {
            debuglog "COM event received for inactive object"
        }
        return;                         # Object has gone away, ignore
    }

    set retcode [catch {
        # We are invoked with cooked values so no need to call variant_value
        uplevel #0 $script [list $callee] $args
    } result]

    if {$::twapi::log_config(twapi_com) && $retcode} {
        debuglog "Event sink callback error ($retcode): $result\n$::errorInfo"
    }

    # $retcode is returned as HRESULT by the Invoke
    return -code $retcode $result
}

#
# Return clsid from a string. If $clsid is a valid CLSID - returns as is
# else tries to convert it from progid. An error is generated if neither
# works
proc twapi::_convert_to_clsid {comid} {
    if {! [Twapi_IsValidGUID $comid]} {
        return [progid_to_clsid $comid]
    }
    return $comid
}

#
# Format a prototype definition for human consumption
# Proto is in the form {DISPID LCID INVOKEFLAGS RETTYPE PARAMTYPES PARAMNAMES}
proc twapi::_format_prototype {name proto} {
    set dispid_lcid [lindex $proto 0]/[lindex $proto 1]
    set ret_type [_vttype_to_string [lindex $proto 3]]
    set invkind [_invkind_to_string [lindex $proto 2]]
    # Distinguish between no parameters and parameters not known
    set paramstr ""
    if {[llength $proto] > 4} {
        set params {}
        foreach param [lindex $proto 4] paramname [lindex $proto 5] {
            if {[string length $paramname]} {
                set paramname " $paramname"
            }
            lassign $param type paramdesc
            set type [_vttype_to_string $type]
            set parammods [_paramflags_to_tokens [lindex $paramdesc 0]]
            if {[llength [lindex $paramdesc 1]]} {
                # Default specified
                lappend parammods "default:[lindex [lindex $paramdesc 1] 1]"
            }
            lappend params "\[$parammods\] $type$paramname"
        }
        set paramstr " ([join $params {, }])"
    }
    return "$dispid_lcid $invkind $ret_type ${name}${paramstr}"
}

# Convert parameter modifiers to string tokens.
# modifiers is list of integer flags or tokens.
proc twapi::_paramflags_to_tokens {modifiers} {
    array set tokens {}
    foreach mod $modifiers {
        if {! [string is integer -strict $mod]} {
            # mod is a token itself
            set tokens($mod) ""
        } else {
            foreach tok [_make_symbolic_bitmask $mod {
                in 1
                out 2
                lcid 4
                retval 8
                optional 16
                hasdefault 32
                hascustom  64
            }] {
                set tokens($tok) ""
            }
        }
    }

    # For cosmetic reasons, in/out should be first and remaining sorted
    # Also (in,out) -> inout
    if {[info exists tokens(in)]} {
        if {[info exists tokens(out)]} {
            set inout [list inout]
            unset tokens(in)
            unset tokens(out)
        } else {
            set inout [list in]
            unset tokens(in)
        }
    } else {
        if {[info exists tokens(out)]} {
            set inout [list out]
            unset tokens(out)
        }
    }

    if {[info exists inout]} {
        return [linsert [lsort [array names tokens]] 0 $inout]
    } else {
        return [lsort [array names tokens]]
    }
}

#
# Map method invocation code to string
# Return code itself if no match
proc twapi::_invkind_to_string {code} {
    return [kl_get {
        1  func
        2  propget
        4  propput
        8  propputref
    } $code $code]
}

#
# Map string method invocation symbol to code
# Error if no match and not an integer
proc twapi::_string_to_invkind {s} {
    if {[string is integer $s]} { return $s }
    return [kl_get {
        func    1
        propget 2
        propput 4
        propputref 8
    } $s]
}


#
# Convert a VT typedef to a string
# vttype may be nested
proc twapi::_vttype_to_string {vttype} {
    set vts [_vtcode_to_string [lindex $vttype 0]]
    if {[llength $vttype] < 2} {
        return $vts
    }

    return [list $vts [_vttype_to_string [lindex $vttype 1]]]
}

#
# Convert VT codes to strings
proc twapi::_vtcode_to_string {vt} {
    return [kl_get {
        2        i2
        3        i4
        4       r4
        5       r8
        6       cy
        7       date
        8       bstr
        9       idispatch
        10       error
        11       bool
        12       variant
        13       iunknown
        14       decimal
        16       i1
        17       ui1
        18       ui2
        19       ui4
        20       i8
        21       ui8
        22       int
        23       uint
        24       void
        25       hresult
        26       ptr
        27       safearray
        28       carray
        29       userdefined
        30       lpstr
        31       lpwstr
        36       record
    } $vt $vt]
}

proc twapi::_string_to_base_vt {tok} {
    # Only maps base VT tokens to numeric value
    # TBD - record and userdefined?
    return [dict get {
        i2 2
        i4 3
        r4 4
        r8 5
        cy 6
        date 7
        bstr 8
        idispatch 9
        error 10
        bool 11
        iunknown 13
        decimal 14
        i1 16
        ui1 17
        ui2 18
        ui4 19
        i8 20
        ui8 21
        int 22
        uint 23
        hresult 25
        userdefined 29
        record 36
    } [string tolower $tok]]

}

#
# Get ADSI provider service
proc twapi::_adsi {{prov WinNT} {path {//.}}} {
    return [comobj_object "${prov}:$path"]
}

# Get cached IDispatch and IUNknown IID's
proc twapi::_iid_iunknown {} {
    return $::twapi::_name_to_iid_cache(iunknown)
}
proc twapi::_iid_idispatch {} {
    return $::twapi::_name_to_iid_cache(idispatch)
}

#
# Return IID and name given a IID or name
proc twapi::_resolve_iid {name_or_iid} {

    # IID -> name mapping is more efficient so first assume it is
    # an IID else we will unnecessarily trundle through the whole
    # registry area looking for an IID when we already have it
    # Assume it is a name
    set other [iid_to_name $name_or_iid]
    if {$other ne ""} {
        # It was indeed the IID. Return the pair
        return [list $name_or_iid $other]
    }

    # Else resolve as a name
    set other [name_to_iid $name_or_iid]
    if {$other ne ""} {
        # Yep
        return [list $other $name_or_iid]
    }

    win32_error 0x80004002 "Could not find IID $name_or_iid"
}


namespace eval twapi {
    # Enable use of TclOO for new Tcl versions. To override setting
    # applications should define and set before sourcing this file.
    variable use_tcloo_for_com 
    if {![info exists use_tcloo_for_com]} {
        set use_tcloo_for_com [package vsatisfies [package require Tcl] 8.6b2]
    }
    if {$use_tcloo_for_com} {
        interp alias {} ::twapi::class {} ::oo::class
        proc ::oo::define::twapi_exportall {} {
            uplevel 1 export [info class methods [lindex [info level -1] 1] -private]
        }
        proc comobj? {cobj} {
            # TBD - would it be faster to keep explicit track through
            # a dictionary ?
            set cobj [uplevel 1 [list namespace which -command $cobj]]
            if {[info object isa object $cobj] &&
                [info object isa typeof $cobj ::twapi::Automation]} {
                return 1
            } else {
                return 0
            }
        }
        proc comobj_instances {} {
            set comobj_classes [list ::twapi::Automation]
            set objs {}
            while {[llength $comobj_classes]} {
                set comobj_classes [lassign $comobj_classes class]
                lappend objs {*}[info class instances $class]
                lappend comobj_classes {*}[info class subclasses $class]
            }
            # Get rid of dups which may occur if subclasses use
            # multiple (diamond type) inheritance
            return [lsort -unique $objs]
        }
    } else {
        package require metoo
        interp alias {} ::twapi::class {} ::metoo::class
        namespace eval ::metoo::define {
            proc twapi_exportall {args} {
                # args is dummy to match metoo's class definition signature
                # Nothing to do, all methods are metoo are public
            }
        }
        proc comobj? {cobj} {
            set cobj [uplevel 1 [list namespace which -command $cobj]]
            return [metoo::introspect object isa $cobj ::twapi::Automation]
        }
        proc comobj_instances {} {
            return [metoo::introspect object list ::twapi::Automation]
        }
    }

    # The prototype cache is indexed a composite key consisting of
    #  - the GUID of the interface,
    #  - the name of the function
    #  - the LCID
    #  - the invocation kind (as an integer)
    # Each value contains the full prototype in a form
    # that can be passed to IDispatch_Invoke. This is a list with the
    # elements {DISPID LCID INVOKEFLAGS RETTYPE PARAMTYPES PARAMNAMES}
    # Here PARAMTYPES is a list each element of which describes a
    # parameter in the following format:
    #     {TYPE {FLAGS DEFAULT} NAMEDARGVALUE} where DEFAULT is optional
    # and NAMEDARGVALUE only appears (optionally) when the prototype is
    # passed to Invoke, not in the cached prototype itself.
    # PARAMNAMES is list of parameter names in order and is
    # only present if PARAMTYPES is also present.
    
    variable _dispatch_prototype_cache
    array set _dispatch_prototype_cache {}
}


interp alias {} twapi::_dispatch_prototype_get {} twapi::dispatch_prototype_get
proc twapi::dispatch_prototype_get {guid name lcid invkind vproto} {
    variable _dispatch_prototype_cache
    set invkind [::twapi::_string_to_invkind $invkind]
    if {[info exists _dispatch_prototype_cache($guid,$name,$lcid,$invkind)]} {
        # Note this may be null if that name does not exist in the interface
        upvar 1 $vproto proto
        set proto $_dispatch_prototype_cache($guid,$name,$lcid,$invkind)
        return 1
    }
    return 0
}

# Update a prototype in cache. Note lcid and invkind cannot be
# picked up from prototype since it might be empty.
interp alias {} twapi::_dispatch_prototype_set {} twapi::dispatch_prototype_set
proc twapi::dispatch_prototype_set {guid name lcid invkind proto} {
    # If the prototype does not contain the 5th element (params)
    # it is a constructed prototype and we do NOT cache it as the
    # disp id can change. Note empty prototypes are cached so
    # we don't keep looking up something that does not exist
    # Bug 130

    if {[llength $proto] == 4} {
        return
    }

    variable _dispatch_prototype_cache
    set invkind [_string_to_invkind $invkind]
    set _dispatch_prototype_cache($guid,$name,$lcid,$invkind) $proto
    return
}

# Explicitly set prototypes for a guid 
# protolist is a list of alternating name and prototype pairs.
# Each prototype must contain the LCID and invkind fields
proc twapi::_dispatch_prototype_load {guid protolist} {
    foreach {name proto} $protolist {
        dispatch_prototype_set $guid $name [lindex $proto 1] [lindex $proto 2] $proto
    }
}

proc twapi::_parse_dispatch_paramdef {paramdef} {
    set errormsg "Invalid parameter or return type declaration '$paramdef'"

    set paramregex {^(\[[^\]]*\])?\s*(\w+)\s*(\[\s*\])?\s*([*]?)\s*(\w+)?$}
    if {![regexp $paramregex [string trim $paramdef] def attrs paramtype safearray ptr paramname]} {
        error $errormsg
    }

    if {[string length $paramname]} {
        lappend paramnames $paramname
    }
    # attrs can be in, out, opt separated by spaces
    set paramflags 0
    foreach attr [string range $attrs 1 end-1] {
        switch -exact -- $attr {
            in {set paramflags [expr {$paramflags | 1}]}
            out {set paramflags [expr {$paramflags | 2}]}
            inout {set paramflags [expr {$paramflags | 3}]}
            opt -
            optional {set paramflags [expr {$paramflags | 16}]}
            default {error "Unknown parameter attribute $attr"}
        }
    }
    if {($paramflags & 3) == 0} {
        set paramflags [expr {$paramflags | 1}]; # in param if unspecified
    }
    # Resolve parameter type. It can be 
    #  - a safearray of base types or "variant"s (not pointers)
    #  - a pointer to a base type
    #  - a pointer to a safearray
    #  - a base type or "variant"
    switch -exact -- $paramtype {
        variant { set paramtype 12 }
        void    { set paramtype 24 }
        default { set paramtype [_string_to_base_vt $paramtype] }
    }
    if {[string length $safearray]} {
        if {$paramtype == 24} {
            # Safearray of type void is an invalid type decl
            error $errormsg
        }
        set paramtype [list 27 $paramtype]
    }
    if {[string length $ptr]} {
        if {$paramtype == 24} {
            # Pointer to type void is an invalid type
            error $errormsg
        }
        set paramtype [list 26 $paramtype]
    }

    return [list $paramflags $paramtype $paramname]
}

proc twapi::define_dispatch_prototypes {guid protos args} {
    array set opts [parseargs args {
        {lcid.int 0}
    } -maxleftover 0]

    set guid [canonicalize_guid $guid]

    set defregx {^\s*(\w+)\s+(\d+)\s+(\w[^\(]*)\(([^\)]*)\)(.*)$}
    set parsed_protos {}
    # Loop picking out one prototype in each interation
    while {[regexp $defregx $protos -> membertype memid rettype paramstring protos]} {
        set params {}
        set paramnames {}
        foreach paramdef [split $paramstring ,] {
            lassign [_parse_dispatch_paramdef $paramdef] paramflags paramtype paramname
            if {[string length $paramname]} {
                lappend paramnames $paramname
            }
            lappend params [list $paramtype [list $paramflags]]
        }
        if {[llength $paramnames] &&
            [llength $params] != [llength $paramnames]} {
            error "Missing parameter name in '$paramstring'. All parameter names must be specified or none at all."
        }

        lassign [_parse_dispatch_paramdef $rettype] _ rettype name 
        set invkind [_string_to_invkind $membertype]
        set proto [list $memid $opts(lcid) $invkind $rettype $params $paramnames]
        lappend parsed_protos $name $proto
    }

    set protos [string trim $protos]
    if {[string length $protos]} {
        error "Invalid dispatch prototype: '$protos'"
    }
    
    _dispatch_prototype_load $guid $parsed_protos
}

# Used to track when interface proxies are renamed/deleted
proc twapi::_interface_proxy_tracer {ifc oldname newname op} {
    variable _interface_proxies
    if {$op eq "rename"} {
        if {$oldname eq $newname} return
        set _interface_proxies($ifc) $newname
    } else {
        unset _interface_proxies($ifc)
    }
}


# Return a COM interface proxy object for the specified interface.
# If such an object already exists, it is returned. Otherwise a new one
# is created. $ifc must be a valid COM Interface pointer for which
# the caller is holding a reference. Caller relinquishes ownership
# of the interface and must solely invoke operations through the
# returned proxy object. When done with the object, call the Release
# method on it, NOT destroy.
# TBD - how does this interact with security blankets ?
proc twapi::make_interface_proxy {ifc} {
    variable _interface_proxies

    if {[info exists _interface_proxies($ifc)]} {
        set proxy $_interface_proxies($ifc)
        $proxy AddRef
        if {! [pointer_null? $ifc]} {
            # Release the caller's ref to the interface since we are holding
            # one in the proxy object
            ::twapi::IUnknown_Release $ifc
        }
    } else {
        if {[pointer_null? $ifc]} {
            set proxy [INullProxy new $ifc]
        } else {
            set ifcname [pointer_type $ifc]
            set proxy [${ifcname}Proxy new $ifc]
        }
        set _interface_proxies($ifc) $proxy
        trace add command $proxy {rename delete} [list ::twapi::_interface_proxy_tracer $ifc]
    }
    return $proxy
}

# "Null" object - clones IUnknownProxy but will raise error on method calls
# We could have inherited but IUnknownProxy assumes non-null ifc so it
# and its inherited classes do not have to check for null in every method.
twapi::class create ::twapi::INullProxy {
    constructor {ifc} {
        my variable _ifc
        # We keep the interface pointer because it encodes type information
        if {! [::twapi::pointer_null? $ifc]} {
            error "Attempt to create a INullProxy with non-NULL interface"
        }

        set _ifc $ifc

        my variable _nrefs;   # Internal ref count (held by app)
        set _nrefs 1
    }

    method @Null? {} { return 1 }
    method @Type {} {
        my variable _ifc
        return [::twapi::pointer_type $_ifc]
    }
    method @Type? {type} {
        my variable _ifc
        return [::twapi::pointer? $_ifc $type]
    }
    method AddRef {} {
        my variable _nrefs
        # We maintain our own ref counts. _ifc is null so do not
        # call the COM AddRef !
        incr _nrefs
    }

    method Release {} {
        my variable _nrefs
        if {[incr _nrefs -1] == 0} {
            my destroy
        }
    }

    method DebugRefCounts {} {
        my variable _nrefs

        # Return out internal ref as well as the COM ones
        # Note latter is always 0 since _ifc is always NULL.
        return [list $_nrefs 0]
    }

    method QueryInterface {name_or_iid} {
        error "Attempt to call QueryInterface called on NULL pointer"
    }

    method @QueryInterface {name_or_iid} {
        error "Attempt to call QueryInterface called on NULL pointer"
    }

    # Parameter is for compatibility with IUnknownProxy
    method @Interface {{addref 1}} {
        my variable _ifc
        return $_ifc
    }

    twapi_exportall
}

twapi::class create ::twapi::IUnknownProxy {
    # Note caller must hold ref on the ifc. This ref is passed to
    # the proxy object and caller must not make use of that ref
    # unless it does an AddRef on it.
    constructor {ifc {objclsid ""}} {
        if {[::twapi::pointer_null? $ifc]} {
            error "Attempt to register a NULL interface"
        }

        my variable _ifc
        set _ifc $ifc

        my variable _clsid
        set _clsid $objclsid

        my variable _blanket;   # Security blanket
        set _blanket [list ]

        # We keep an internal reference count instead of explicitly
        # calling out to the object's AddRef/Release every time.
        # When the internal ref count goes to 0, we will invoke the 
        # object's "native" Release.
        #
        # Note the primary purpose of maintaining our internal reference counts
        # is not efficiency by shortcutting the "native" AddRefs. It is to
        # prevent crashes by bad application code; we can just generate an
        # error instead by having the command go away.
        my variable _nrefs;   # Internal ref count (held by app)

        set _nrefs 1
    }

    destructor {
        my variable _ifc
        ::twapi::IUnknown_Release $_ifc
    }

    method AddRef {} {
        my variable _nrefs
        # We maintain our own ref counts. Not pass it on to the actual object
        incr _nrefs
    }

    method Release {} {
        my variable _nrefs
        if {[incr _nrefs -1] == 0} {
            my destroy
        }
    }

    method DebugRefCounts {} {
        my variable _nrefs
        my variable _ifc

        # Return out internal ref as well as the COM ones
        # Note latter are unstable and only to be used for
        # debugging
        twapi::IUnknown_AddRef $_ifc
        return [list $_nrefs [twapi::IUnknown_Release $_ifc]]
    }

    method QueryInterface {name_or_iid} {
        my variable _ifc
        lassign [::twapi::_resolve_iid $name_or_iid] iid name
        return [::twapi::Twapi_IUnknown_QueryInterface $_ifc $iid $name]
    }

    # Same as QueryInterface except return "" instead of exception
    # if interface not found and returns proxy object instead of interface
    method @QueryInterface {name_or_iid {set_blanket 0}} {
        my variable _blanket
        ::twapi::trap {
            set proxy [::twapi::make_interface_proxy [my QueryInterface $name_or_iid]]
            if {$set_blanket && [llength $_blanket]} {
                $proxy @SetSecurityBlanket $_blanket
            }
            return $proxy
        } onerror {TWAPI_WIN32 0x80004002} {
            # No such interface, return "", don't generate error
            return ""
        } onerror {} {
            if {[info exists proxy]} {
                catch {$proxy Release}
            }
            rethrow
        }
    }

    method @Type {} {
        my variable _ifc
        return [::twapi::pointer_type $_ifc]
    }

    method @Type? {type} {
        my variable _ifc
        return [::twapi::pointer? $_ifc $type]
    }

    method @Null? {} {
        my variable _ifc
        return [::twapi::pointer_null? $_ifc]
    }

    # Returns raw interface. Caller must call IUnknown_Release on it
    # iff addref is passed as true (default)
    method @Interface {{addref 1}} {
        my variable _ifc
        if {$addref} {
            ::twapi::IUnknown_AddRef $_ifc
        }
        return $_ifc
    }

    # Returns out class id - old deprecated - use GetCLSID
    method @Clsid {} {
        my variable _clsid
        return $_clsid
    }

    method @GetCLSID {} {
        my variable _clsid
        return $_clsid
    }

    method @SetCLSID {clsid} {
        my variable _clsid
        set _clsid $clsid
        return
    }

    method @SetSecurityBlanket blanket {
        my variable _ifc _blanket
        # In-proc components will not support IClientSecurity interface
        # and will raise an error. That's the for the caller to be careful
        # about.
        twapi::CoSetProxyBlanket $_ifc {*}$blanket
        set _blanket $blanket
        return
    }

    method @GetSecurityBlanket {} {
        my variable _blanket
        return $_blanket
    }
    

    twapi_exportall
}

twapi::class create ::twapi::IDispatchProxy {
    superclass ::twapi::IUnknownProxy

    destructor {
        my variable _typecomp
        if {[info exists _typecomp] && $_typecomp ne ""} {
            $_typecomp Release
        }
        next
    }

    method GetTypeInfoCount {} {
        my variable _ifc
        return [::twapi::IDispatch_GetTypeInfoCount $_ifc]
    }

    # names is list - method name followed by parameter names
    # Returns list of name dispid pairs
    method GetIDsOfNames {names {lcid 0}} {
        my variable _ifc
        return [::twapi::IDispatch_GetIDsOfNames $_ifc $names $lcid]
    }

    # Get dispid of a method (without parameter names)
    method @GetIDOfOneName {name {lcid 0}} {
        return [lindex [my GetIDsOfNames [list $name] $lcid] 1]
    }

    method GetTypeInfo {{infotype 0} {lcid 0}} {
        my variable _ifc
        if {$infotype != 0} {error "Parameter infotype must be 0"}
        return [::twapi::IDispatch_GetTypeInfo $_ifc $infotype $lcid]
    }

    method @GetTypeInfo {{lcid 0}} {
        return [::twapi::make_interface_proxy [my GetTypeInfo 0 $lcid]]
    }

    method Invoke {prototype args} {
        my variable _ifc
        if {[llength $prototype] == 0 && [llength $args] == 0} {
            # Treat as a property get DISPID_VALUE (default value)
            # {dispid=0, lcid=0 cmd=propget(2) ret type=bstr(8) {} (no params)}
            set prototype {0 0 2 8 {}}
        } else {
            # TBD - optimize by precomputing if a prototype needs this processing
            # If any arguments are comobjs, may need to replace with the 
            # IDispatch interface.
            # Moreover, we have to manage the reference counts for both
            # IUnknown and IDispatch - 
            #  - If the parameter is an IN parameter, ref counts do not need
            #    to change.
            #  - If the parameter is an OUT parameter, we are not passing
            #    an interface in, so nothing to do
            #  - If the parameter is an INOUT, we need to AddRef it since
            #    the COM method will Release it when storing a replacement
            # HERE WE ONLY DO THE CHECK FOR COMOBJ. The AddRef checks are
            # DONE IN THE C CODE (if necessary)

            set iarg -1
            set args2 {}
            foreach arg $args {
                incr iarg
                # TBD - optimize this loop
                set argtype  [lindex $prototype 4 $iarg 0]
                set argflags 0
                if {[llength [lindex $prototype 4 $iarg 1]]} {
                    set argflags [lindex $prototype 4 $iarg 1 0]
                }
                if {$argflags & 1} {
                    # IN param
                    if {$argflags & 2} {
                        # IN/OUT
                        # We currently do NOT handle a In/Out - skip for now TBD
                        # In the future we will have to check contents of
                        # the passed arg as a variable in the CALLER's context
                    } else {
                        # Pure IN param. Check if it is VT_DISPATCH or
                        # VT_VARIANT. Else nothing
                        # to do
                        if {[lindex $argtype 0] == 26} {
                            # Pointer, get base type
                            set argtype [lindex $argtype 1]
                        }
                        if {[lindex $argtype 0] == 9 || [lindex $argtype 0] == 12} {
                            # If a comobj was passed, need to extract the
                            # dispatch pointer.
                            # We do not want change the internal type so
                            # save it since comobj? changes it to cmdProc.
                            # Moreover, do not check for some types that
                            # could not be a comobj. In particular,
                            # if a list type, we do not even check
                            # because it cannot be a comobj and even checking
                            # will result in nested list types being
                            # destroyed which affects safearray type detection
                            if {[twapi::tcltype $arg] ni {bytecode TwapiOpaque list int double bytearray dict wideInt booleanString}} {
                                if {[twapi::comobj? $arg]} {
                                    # Note we do not addref when getting the interface
                                    # (last param 0) because not necessary for IN
                                    # params, AND it is the C code's responsibility
                                    # anyways
                                    set arg [$arg -interface 0]
                                }
                            }
                        }
                    }

                } else {
                    # Not an IN param. Nothing to be done
                }
                
                lappend args2 $arg
            }
            set args $args2
        }

        # The uplevel is so that if some parameters are output, the varnames
        # are resolved in caller
        uplevel 1 [list ::twapi::IDispatch_Invoke $_ifc $prototype] $args
    }

    # Methods are tried in the order specified by invkinds.
    method @Invoke {name invkinds lcid params {namedargs {}}} {
        if {$name eq ""} {
            # Default method
            return [uplevel 1 [list [self] Invoke {}] $params]
        } else {
            set nparams [llength $params]

            # We will try for each invkind to match. matches can be of
            # different degrees, in descending priority -
            # 1. prototype has parameter info and num params match exactly
            # 2. prototype has parameter info and num params is greater
            #    than supplied arguments (assumes others have defaults)
            # 3. prototype has no parameter information
            # Within these classes, the order of invkinds determines
            # priority

            foreach invkind $invkinds {
                set proto [my @Prototype $name $invkind $lcid]
                if {[llength $proto]} {
                    if {[llength $proto] < 5} {
                        # No parameter information
                        lappend class3 $proto
                    } else {
                        if {[llength [lindex $proto 4]] == $nparams} {
                            lappend class1 $proto
                            break; # Class 1 match, no need to try others
                        } elseif {[llength [lindex $proto 4]] > $nparams} {
                            lappend class2 $proto
                        } else {
                            # Ignore - proto has fewer than supplied params
                            # Could not be a match
                        }
                    }
                }
            }

            # For exact match (class1), we do not need the named arguments as
            # positional arguments take priority. When number of passed parameters
            # is fewer than those in prototype, check named arguments and use those
            # values. If no parameter information, we can't use named arguments
            # anyways.
            if {[info exists class1]} {
                set proto [lindex $class1 0]
            } elseif {[info exists class2]} {
                set proto [lindex $class2 0]
                # If we are passed named arguments AND the prototype also
                # has parameter name information, replace the default values
                # in the parameter definitions with the named arg value if
                # it exists.
                if {[llength $namedargs] &&
                    [llength [set paramnames [lindex $proto 5]]]} {
                    foreach {paramname paramval} $namedargs {
                        set paramindex [lsearch -nocase $paramnames $paramname]
                        if {$paramindex < 0} {
                            twapi::win32_error 0x80020004 "No parameter with name '$paramname' found for method '$name'"
                        }

                        # Set the default value field of the
                        # appropriate parameter to the named arg value
                        set paramtype [lindex $proto 4 $paramindex 0]

                        # If parameter is VT_DISPATCH or VT_VARIANT, 
                        # convert from comobj if necessary.
                        if {$paramtype == 9 || $paramtype == 12} {
                            # We do not want to change the internal type by
                            # shimmering. See similar comments in Invoke
                            if {[twapi::tcltype $paramval] ni {"" TwapiOpaque list int double bytearray dict wideInt booleanString}} {
                                if {[::twapi::comobj? $paramval]} {
                                    # Note no AddRef when getting the interface
                                    # (last param 0) because it is the C code's
                                    # responsibility based on in/out direction
                                    set paramval [$paramval -interface 0]
                                }
                            }
                        }

                        # Replace the default value field for that param def
                        lset proto 4 $paramindex [linsert [lrange [lindex $proto 4 $paramindex] 0 1] 2 $paramval]
                    }
                }
            } elseif {[info exists class3]} {
                set proto [lindex $class3 0]
            } else {
                # No prototype via typecomp / typeinfo available. No lcid worked.
                # We have to use the last resort of GetIDsOfNames
                set dispid [my @GetIDOfOneName [list $name] 0]
                # TBD - should we cache result ? Probably not.
                if {$dispid ne ""} {
                    # Note params field (last) is missing signifying we do not
                    # know prototypes
                    set proto [list $dispid 0 [lindex $invkinds 0] 8]
                } else {
                    twapi::win32_error 0x80020003 "No property or method found with name '$name'."
                }
            }

            # Need uplevel so by-ref param vars are resolved correctly
            return [uplevel 1 [list [self] Invoke $proto] $params]
        }
    }

    # Get prototype that match the specified name
    method @Prototype {name invkind lcid} {
        my variable  _ifc  _guid  _typecomp

        # Always need the GUID so get it we have not done so already
        if {![info exists _guid]} {
            my @InitTypeCompAndGuid
        }
        # Note above call may still have failed to init _guid

        # If we have been through here before and have our guid,
        # check if a prototype exists and return it. 
        if {[info exists _guid] && $_guid ne "" &&
            [::twapi::_dispatch_prototype_get $_guid $name $lcid $invkind proto]} {
            return $proto
        }

        # Not in cache, have to look for it
        # Use the ITypeComp for this interface if we do not
        # already have it. We trap any errors because we will retry with
        # different LCID's below.
        set proto {}
        if {![info exists _typecomp]} {
            my @InitTypeCompAndGuid
        }
        if {$_typecomp ne ""} {
            ::twapi::trap {

                set invkind [::twapi::_string_to_invkind $invkind]
                set lhash   [::twapi::LHashValOfName $lcid $name]

                if {![catch {$_typecomp Bind $name $lhash $invkind} binddata] &&
                    [llength $binddata]} {
                    lassign $binddata type data ifc
                    if {$type eq "funcdesc" ||
                        ($type eq "vardesc" && [::twapi::kl_get $data varkind] == 3)} {
                        set params {}
                        set bindti [::twapi::make_interface_proxy $ifc]
                        ::twapi::trap {
                            set params [::twapi::_resolve_params_for_prototype $bindti [::twapi::kl_get $data lprgelemdescParam]]
                            # Param names are needed for named arguments. Index 0 is method name so skip it
                            if {[catch {lrange [$bindti GetNames [twapi::kl_get $data memid]] 1 end} paramnames]} {
                                set paramnames {}
                            }
                        } finally {
                            $bindti Release
                        }
                        set proto [list [::twapi::kl_get $data memid] \
                                       $lcid \
                                       $invkind \
                                       [::twapi::kl_get $data elemdescFunc.tdesc] \
                                       $params $paramnames]
                    } else {
                        ::twapi::IUnknown_Release $ifc; # Don't need ifc but must release
                        twapi::debuglog "IDispatchProxy::@Prototype: Unexpected Bind type: $type, data: $data"
                    }
                }
            } onerror {} {
                # Ignore and retry with other LCID's below
            }
        }


        # If we do not have a guid return because even if we do not
        # have a proto yet,  falling through to try another lcid will not
        # help and in fact will cause infinite recursion.
        
        if {$_guid eq ""} {
            return $proto
        }

        # We do have a guid, store the proto in cache (even if negative)
        ::twapi::dispatch_prototype_set $_guid $name $lcid $invkind $proto

        # If we have the proto return it
        if {[llength $proto]} {
            return $proto
        }

        # Could not find a matching prototype from the typeinfo/typecomp.
        # We are not done yet. We will try and fall back to other lcid's
        # Note we do this AFTER setting the prototype in the cache. That
        # way we prevent (infinite) mutual recursion between lcid fallbacks.
        # The fallback sequence is $lcid -> 0 -> 1033
        # (1033 is US English). Note lcid could itself be 1033
        # default and land up being checked twice times but that's
        # ok since that's a one-time thing, and not very expensive either
        # since the second go-around will hit the cache (negative). 
        # Note the time this is really useful is when the cache has
        # been populated explicitly from a type library since in that
        # case many interfaces land up with a US ENglish lcid (MSI being
        # just one example)

        if {$lcid == 0} {
            # Note this call may further recurse and return either a
            # proto or empty (fail)
            set proto [my @Prototype $name $invkind 1033]
        } else {
            set proto [my @Prototype $name $invkind 0]
        }
        
        # Store it as *original* lcid.
        ::twapi::dispatch_prototype_set $_guid $name $lcid $invkind $proto
        
        return $proto
    }


    # Initialize _typecomp and _guid. Not in constructor because may
    # not always be required. Raises error if not available
    method @InitTypeCompAndGuid {} {
        my variable   _guid   _typecomp
        
        if {[info exists _typecomp]} {
            # Based on code below, if _typecomp exists
            # _guid also exists so no need to check for that
            return
        }

        ::twapi::trap {
            set ti [my @GetTypeInfo 0]
        } onerror {} {
            # We do not raise an error because
            # even without the _typecomp we can try invoking
            # methods via IDispatch::GetIDsOfNames
            twapi::debuglog "Could not ITypeInfo: [twapi::trapresult]"
            if {![info exists _guid]} {
                # Do not overwrite if already set thru @SetGuid or constructor
                # Set to empty otherwise so we know we tried and failed
                set _guid ""
            }
            set _typecomp ""
            return
        }

        ::twapi::trap {
            # In case of dual interfaces, we need the typeinfo for the 
            # dispatch. Again, errors handled in try handlers
            switch -exact -- [::twapi::kl_get [$ti GetTypeAttr] typekind] {
                4 {
                    # Dispatch type, fine, just what we want
                }
                3 {
                    # Interface type, Get the dispatch interface
                    set ti2 [$ti @GetRefTypeInfo [$ti GetRefTypeOfImplType -1]]
                    $ti Release
                    set ti $ti2
                }
                default {
                    error "Interface is not a dispatch interface"
                }
            }
            if {![info exists _guid]} {
                # _guid might have already been valid, do not overwrite
                set _guid [::twapi::kl_get [$ti GetTypeAttr] guid]
            }
            set _typecomp [$ti @GetTypeComp]; # ITypeComp
        } finally {
            $ti Release
        }
    }            

    # Some COM objects like MSI do not have TypeInfo interfaces from
    # where the GUID and TypeComp can be extracted. So we allow caller
    # to explicitly set the GUID so we can look up methods in the
    # dispatch prototype cache if it was populated directly by the
    # application. If guid is not a valid GUID, an attempt is made
    # to look it up as an IID name.
    method @SetGuid {guid} {
        my variable _guid
        if {$guid eq ""} {
            if {![info exists _guid]} {
                my @InitTypeCompAndGuid
            }
        } else {
            if {![::twapi::Twapi_IsValidGUID $guid]} {
                set resolved_guid [::twapi::name_to_iid $guid]
                if {$resolved_guid eq ""} {
                    error "Could not resolve $guid to a Interface GUID."
                }
                set guid $resolved_guid
            }

            if {[info exists _guid] && $_guid ne ""} {
                if {[string compare -nocase $guid $_guid]} {
                    error "Attempt to set the GUID to $guid when the dispatch proxy has already been initialized to $_guid"
                }
            } else {
                set _guid $guid
            }
        }

        return $_guid
    }

    method @GetCoClassTypeInfo {} {
        my variable _ifc

        # We can get the typeinfo for the coclass in one of two ways:
        # If the object supports IProvideClassInfo, we use it. Else
        # we try the following:
        #   - from the idispatch, we get its typeinfo
        #   - from the typeinfo, we get the containing typelib
        #   - then we search the typelib for the coclass clsid

        ::twapi::trap {
            set pci_ifc [my QueryInterface IProvideClassInfo]
            set ti_ifc [::twapi::IProvideClassInfo_GetClassInfo $pci_ifc]
            return [::twapi::make_interface_proxy $ti_ifc]
        } onerror {} {
            # Ignore - try the longer route if we were given the coclass clsid
        } finally {
            if {[info exists pci_ifc]} {
                ::twapi::IUnknown_Release $pci_ifc
            }
            # Note - do not do anything with ti_ifc here, EVEN on error
        }

        set co_clsid [my @Clsid]
        if {$co_clsid eq ""} {
            # E_FAIL
            twapi::win32_error 0x80004005 "Could not get ITypeInfo for coclass: object does not support IProvideClassInfo and clsid not specified."
        }

        set ti [my @GetTypeInfo]
        ::twapi::trap {
            set tl [lindex [$ti @GetContainingTypeLib] 0]
            if {0} {
                $tl @Foreach -guid $co_clsid -type coclass coti {
                    break
                }
                if {[info exists coti]} {
                    return $coti
                }
            } else {
                return [$tl @GetTypeInfoOfGuid $co_clsid]
            }
            twapi::win32_error 0x80004005 "Could not find coclass."; # E_FAIL
        } finally {
            if {[info exists ti]} {
                $ti Release
            }
            if {[info exists tl]} {
                $tl Release
            }
        }
    }

    twapi_exportall
}


twapi::class create ::twapi::IDispatchExProxy {
    superclass ::twapi::IDispatchProxy

    method DeleteMemberByDispID {dispid} {
        my variable _ifc
        return [::twapi::IDispatchEx_DeleteMemberByDispID $_ifc $dispid]
    }

    method DeleteMemberByName {name {lcid 0}} {
        my variable _ifc
        return [::twapi::IDispatchEx_DeleteMemberByName $_ifc $name $lcid]
    }

    method GetDispID {name flags} {
        my variable _ifc
        return [::twapi::IDispatchEx_GetDispID $_ifc $name $flags]
    }

    method GetMemberName {dispid} {
        my variable _ifc
        return [::twapi::IDispatchEx_GetMemberName $_ifc $dispid]
    }

    method GetMemberProperties {dispid flags} {
        my variable _ifc
        return [::twapi::IDispatchEx_GetMemberProperties $_ifc $dispid $flags]
    }

    # For some reason, order of args is different for this call!
    method GetNextDispID {flags dispid} {
        my variable _ifc
        return [::twapi::IDispatchEx_GetNextDispID $_ifc $flags $dispid]
    }

    method GetNameSpaceParent {} {
        my variable _ifc
        return [::twapi::IDispatchEx_GetNameSpaceParent $_ifc]
    }

    method @GetNameSpaceParent {} {
        return [::twapi::make_interface_proxy [my GetNameSpaceParent]]
    }

    method @Prototype {name invkind {lcid 0}} {
        set invkind [::twapi::_string_to_invkind $invkind]

        # First try IDispatch
        ::twapi::trap {
            set proto [next $name $invkind $lcid]
            if {[llength $proto]} {
                return $proto
            }
            # Note negative results ignored, as new members may be added/deleted
            # to an IDispatchEx at any time. We will try below another way.

        } onerror {} {
            # Ignore the error - we will try below using another method
        }

        # Not a simple dispatch interface method. Could be expando
        # type which is dynamically created. NOTE: The member is NOT
        # created until the GetDispID call is made.

        # 10 -> case insensitive, create if required
        set dispid [my GetDispID $name 10]

        # IMPORTANT : prototype retrieval results MUST NOT be cached since
        # underlying object may add/delete members at any time.

        # No type information is available for dynamic members.
        # TBD - is that really true?
        
        # Invoke kind - 1 (method), 2 (propget), 4 (propput)
        if {$invkind == 1} {
            # method
            set flags 0x100
        } elseif {$invkind == 2} {
            # propget
            set flags 0x1
        } elseif {$invkind == 4} {
            # propput
            set flags 0x4
        } else {
            # TBD - what about putref (flags 0x10)
            error "Internal error: Invalid invkind value $invkind"
        }

        # Try at least getting the invocation type but even that is not
        # supported by all objects in which case we assume it can be invoked.
        # TBD - in that case, why even bother doing GetMemberProperties?
        if {! [catch {
            set flags [expr {[my GetMemberProperties 0x115] & $flags}]
        }]} {
            if {! $flags} {
                return {};      # EMpty proto -> no valid name for this invkind
            }
        }

        # Valid invkind or object does not support GetMemberProperties
        # Return type is 8 (BSTR) but does not really matter as 
        # actual type will be set based on what is returned.
        return [list $dispid $lcid $invkind 8]
    }

    twapi_exportall
}


# ITypeInfo 
#-----------

twapi::class create ::twapi::ITypeInfoProxy {
    superclass ::twapi::IUnknownProxy

    method GetRefTypeOfImplType {index} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetRefTypeOfImplType $_ifc $index]
    }

    method GetDocumentation {memid} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetDocumentation $_ifc $memid]
    }

    method GetImplTypeFlags {index} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetImplTypeFlags $_ifc $index]
    }

    method GetNames {index} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetNames $_ifc $index]
    }

    method GetTypeAttr {} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetTypeAttr $_ifc]
    }

    method GetFuncDesc {index} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetFuncDesc $_ifc $index]
    }

    method GetVarDesc {index} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetVarDesc $_ifc $index]
    }

    method GetIDsOfNames {names} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetIDsOfNames $_ifc $names]
    }

    method GetRefTypeInfo {hreftype} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetRefTypeInfo $_ifc $hreftype]
    }

    method @GetRefTypeInfo {hreftype} {
        return [::twapi::make_interface_proxy [my GetRefTypeInfo $hreftype]]
    }

    method GetTypeComp {} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetTypeComp $_ifc]
    }

    method @GetTypeComp {} {
        return [::twapi::make_interface_proxy [my GetTypeComp]]
    }

    method GetContainingTypeLib {} {
        my variable _ifc
        return [::twapi::ITypeInfo_GetContainingTypeLib $_ifc]
    }

    method @GetContainingTypeLib {} {
        lassign [my GetContainingTypeLib] itypelib index
        return [list [::twapi::make_interface_proxy $itypelib] $index]
    }

    method @GetRefTypeInfoFromIndex {index} {
        return [my @GetRefTypeInfo [my GetRefTypeOfImplType $index]]
    }

    # Friendlier version of GetTypeAttr
    method @GetTypeAttr {args} {

        array set opts [::twapi::parseargs args {
            all
            guid
            lcid
            constructorid
            destructorid
            schema
            instancesize
            typekind
            fncount
            varcount
            interfacecount
            vtblsize
            alignment
            majorversion
            minorversion
            aliasdesc
            flags
            idldesc
            memidmap
        } -maxleftover 0]

        array set data [my GetTypeAttr]
        set result [list ]
        foreach {opt key} {
            guid guid
            lcid lcid
            constructorid memidConstructor
            destructorid  memidDestructor
            schema lpstrSchema
            instancesize cbSizeInstance
            fncount cFuncs
            varcount cVars
            interfacecount cImplTypes
            vtblsize cbSizeVft
            alignment cbAlignment
            majorversion wMajorVerNum
            minorversion wMinorVerNum
            aliasdesc tdescAlias
        } {
            if {$opts(all) || $opts($opt)} {
                lappend result -$opt $data($key)
            }
        }

        if {$opts(all) || $opts(typekind)} {
            set typekind $data(typekind)
            if {[info exists ::twapi::_typekind_map($typekind)]} {
                set typekind $::twapi::_typekind_map($typekind)
            }
            lappend result -typekind $typekind
        }

        if {$opts(all) || $opts(flags)} {
            lappend result -flags [::twapi::_make_symbolic_bitmask $data(wTypeFlags) {
                appobject       1
                cancreate       2
                licensed        4
                predeclid       8
                hidden         16
                control        32
                dual           64
                nonextensible 128
                oleautomation 256
                restricted    512
                aggregatable 1024
                replaceable  2048
                dispatchable 4096
                reversebind  8192
                proxy       16384
            }]
        }

        if {$opts(all) || $opts(idldesc)} {
            lappend result -idldesc [::twapi::_make_symbolic_bitmask $data(idldescType) {
                in 1
                out 2
                lcid 4
                retval 8
            }]
        }

        if {$opts(all) || $opts(memidmap)} {
            set memidmap [list ]
            for {set i 0} {$i < $data(cFuncs)} {incr i} {
                array set fninfo [my @GetFuncDesc $i -memid -name]
                lappend memidmap $fninfo(-memid) $fninfo(-name)
            }
            lappend result -memidmap $memidmap
        }

        return $result
    }

    #
    # Get a variable description associated with a type
    method @GetVarDesc {index args} {
        # TBD - add support for retrieving elemdescVar.paramdesc fields

        array set opts [::twapi::parseargs args {
            all
            name
            memid
            schema
            datatype
            value
            valuetype
            varkind
            flags
        } -maxleftover 0]

        array set data [my GetVarDesc $index]
        
        set result [list ]
        foreach {opt key} {
            memid memid
            schema lpstrSchema
            datatype elemdescVar.tdesc
        } {
            if {$opts(all) || $opts($opt)} {
                lappend result -$opt $data($key)
            }
        }


        if {$opts(all) || $opts(value)} {
            if {[info exists data(lpvarValue)]} {
                # Const value
                lappend result -value [lindex $data(lpvarValue) 1]
            } else {
                lappend result -value $data(oInst)
            }
        }

        if {$opts(all) || $opts(valuetype)} {
            if {[info exists data(lpvarValue)]} {
                lappend result -valuetype [lindex $data(lpvarValue) 0]
            } else {
                lappend result -valuetype int
            }
        }

        if {$opts(all) || $opts(varkind)} {
            lappend result -varkind [::twapi::kl_get {
                0 perinstance
                1 static
                2 const
                3 dispatch
            } $data(varkind) $data(varkind)]
        }

        if {$opts(all) || $opts(flags)} {
            lappend result -flags [::twapi::_make_symbolic_bitmask $data(wVarFlags) {
                readonly       1
                source       2
                bindable        4
                requestedit       8
                displaybind         16
                defaultbind        32
                hidden           64
                restricted 128
                defaultcollelem 256
                uidefault    512
                nonbrowsable 1024
                replaceable  2048
                immediatebind 4096
            }]
        }
        
        if {$opts(all) || $opts(name)} {
            set result [concat $result [my @GetDocumentation $data(memid) -name]]
        }    

        return $result
    }

    method @GetFuncDesc {index args} {
        array set opts [::twapi::parseargs args {
            all
            name
            memid
            funckind
            invkind
            callconv
            params
            paramnames
            flags
            datatype
            resultcodes
            vtbloffset
        } -maxleftover 0]

        array set data [my GetFuncDesc $index]
        set result [list ]

        if {$opts(all) || $opts(paramnames)} {
            lappend result -paramnames [lrange [my GetNames $data(memid)] 1 end]
        }
        foreach {opt key} {
            memid       memid
            vtbloffset  oVft
            datatype    elemdescFunc.tdesc
            resultcodes lprgscode
        } {
            if {$opts(all) || $opts($opt)} {
                lappend result -$opt $data($key)
            }
        }

        if {$opts(all) || $opts(funckind)} {
            lappend result -funckind [::twapi::kl_get {
                0 virtual
                1 purevirtual
                2 nonvirtual
                3 static
                4 dispatch
            } $data(funckind) $data(funckind)]
        }

        if {$opts(all) || $opts(invkind)} {
            lappend result -invkind [::twapi::_string_to_invkind $data(invkind)]
        }

        if {$opts(all) || $opts(callconv)} {
            lappend result -callconv [::twapi::kl_get {
                0 fastcall
                1 cdecl
                2 pascal
                3 macpascal
                4 stdcall
                5 fpfastcall
                6 syscall
                7 mpwcdecl
                8 mpwpascal
            } $data(callconv) $data(callconv)]
        }

        if {$opts(all) || $opts(flags)} {
            lappend result -flags [::twapi::_make_symbolic_bitmask $data(wFuncFlags) {
                restricted   1
                source       2
                bindable     4
                requestedit  8
                displaybind  16
                defaultbind  32
                hidden       64
                usesgetlasterror  128
                defaultcollelem 256
                uidefault    512
                nonbrowsable 1024
                replaceable  2048
                immediatebind 4096
            }]
        }

        if {$opts(all) || $opts(params)} {
            set params [list ]
            foreach param $data(lprgelemdescParam) {
                lassign $param paramtype paramdesc
                set paramflags [::twapi::_paramflags_to_tokens [lindex $paramdesc 0]]
                if {[llength $paramdesc] > 1} {
                    # There is a default value associated with the parameter
                    lappend params [list $paramtype $paramflags [lindex $paramdesc 1]]
                } else {
                    lappend params [list $paramtype $paramflags]
                }
            }
            lappend result -params $params
        }

        if {$opts(all) || $opts(name)} {
            set result [concat $result [my @GetDocumentation $data(memid) -name]]
        }    

        return $result
    }

    #
    # Get documentation for a element of a type
    method @GetDocumentation {memid args} {
        array set opts [::twapi::parseargs args {
            all
            name
            docstring
            helpctx
            helpfile
        } -maxleftover 0]

        lassign [my GetDocumentation $memid] name docstring helpctx helpfile

        set result [list ]
        foreach opt {name docstring helpctx helpfile} {
            if {$opts(all) || $opts($opt)} {
                lappend result -$opt [set $opt]
            }
        }
        return $result
    }

    method @GetName {{memid -1}} {
        return [lindex [my @GetDocumentation $memid -name] 1]
    }

    method @GetImplTypeFlags {index} {
        return [::twapi::_make_symbolic_bitmask \
                    [my GetImplTypeFlags $index] \
                    {
                        default      1
                        source       2
                        restricted   4
                        defaultvtable 8
                    }]  
    }

    #
    # Get the typeinfo for the default source interface of a coclass
    # This object must be the typeinfo of the coclass
    method @GetDefaultSourceTypeInfo {} {
        set count [lindex [my @GetTypeAttr -interfacecount] 1]
        for {set i 0} {$i < $count} {incr i} {
            set flags [my GetImplTypeFlags $i]
            # default 0x1, source 0x2
            if {($flags & 3) == 3} {
                # Our source interface implementation can only handle IDispatch
                # so check if the source interface is that else keep looking.
                # We even ignore dual interfaces because we cannot then
                # assume caller will use the dispatch version
                set ti [my @GetRefTypeInfoFromIndex $i]
                array set typeinfo [$ti GetTypeAttr]
                # typekind == 4 -> IDispatch,
                # flags - 0x1000 -> dispatchable, 0x40 -> dual
                if {$typeinfo(typekind) == 4 &&
                    ($typeinfo(wTypeFlags) & 0x1000) &&
                    !($typeinfo(wTypeFlags) & 0x40)} {
                    return $ti
                }
                $ti destroy
            }
        }
        return ""
    }

    twapi_exportall
}


# ITypeLib
#----------

twapi::class create ::twapi::ITypeLibProxy {
    superclass ::twapi::IUnknownProxy

    method GetDocumentation {index} {
        my variable _ifc
        return [::twapi::ITypeLib_GetDocumentation $_ifc $index]
    }
    method GetTypeInfoCount {} {
        my variable _ifc
        return [::twapi::ITypeLib_GetTypeInfoCount $_ifc]
    }
    method GetTypeInfoType {index} {
        my variable _ifc
        return [::twapi::ITypeLib_GetTypeInfoType $_ifc $index]
    }
    method GetLibAttr {} {
        my variable _ifc
        return [::twapi::ITypeLib_GetLibAttr $_ifc]
    }
    method GetTypeInfo {index} {
        my variable _ifc
        return [::twapi::ITypeLib_GetTypeInfo $_ifc $index]
    }
    method @GetTypeInfo {index} {
        return [::twapi::make_interface_proxy [my GetTypeInfo $index]]
    }
    method GetTypeInfoOfGuid {guid} {
        my variable _ifc
        return [::twapi::ITypeLib_GetTypeInfoOfGuid $_ifc $guid]
    }
    method @GetTypeInfoOfGuid {guid} {
        return [::twapi::make_interface_proxy [my GetTypeInfoOfGuid $guid]]
    }
    method @GetTypeInfoType {index} {
        set typekind [my GetTypeInfoType $index]
        if {[info exists ::twapi::_typekind_map($typekind)]} {
            set typekind $::twapi::_typekind_map($typekind)
        }
        return $typekind
    }

    method @GetDocumentation {id args} {
        array set opts [::twapi::parseargs args {
            all
            name
            docstring
            helpctx
            helpfile
        } -maxleftover 0]

        lassign [my GetDocumentation $id] name docstring helpctx helpfile
        set result [list ]
        foreach opt {name docstring helpctx helpfile} {
            if {$opts(all) || $opts($opt)} {
                lappend result -$opt [set $opt]
            }
        }
        return $result
    }

    method @GetName {} {
        return [lindex [my GetDocumentation -1] 0]
    }

    method @GetLibAttr {args} {
        array set opts [::twapi::parseargs args {
            all
            guid
            lcid
            syskind
            majorversion
            minorversion
            flags
        } -maxleftover 0]

        array set data [my GetLibAttr]
        set result [list ]
        foreach {opt key} {
            guid guid
            lcid lcid
            majorversion wMajorVerNum
            minorversion wMinorVerNum
        } {
            if {$opts(all) || $opts($opt)} {
                lappend result -$opt $data($key)
            }
        }

        if {$opts(all) || $opts(flags)} {
            lappend result -flags [::twapi::_make_symbolic_bitmask $data(wLibFlags) {
                restricted      1
                control         2
                hidden          4
                hasdiskimage    8
            }]
        }

        if {$opts(all) || $opts(syskind)} {
            lappend result -syskind [::twapi::kl_get {
                0 win16
                1 win32
                2 mac
            } $data(syskind) $data(syskind)]
        }

        return $result
    }

    #
    # Iterate through a typelib. Caller is responsible for releasing
    # each ITypeInfo passed to it
    # 
    method @Foreach {args} {

        array set opts [::twapi::parseargs args {
            type.arg
            name.arg
            guid.arg
        } -maxleftover 2 -nulldefault]

        if {[llength $args] != 2} {
            error "Syntax error: Should be '[self] @Foreach ?options? VARNAME SCRIPT'"
        }

        lassign $args varname script
        upvar $varname varti

        set count [my GetTypeInfoCount]
        for {set i 0} {$i < $count} {incr i} {
            if {$opts(type) ne "" && $opts(type) ne [my @GetTypeInfoType $i]} {
                continue;                   # Type does not match
            }
            if {$opts(name) ne "" &&
                [string compare -nocase $opts(name) [lindex [my @GetDocumentation $i -name] 1]]} {
                continue;                   # Name does not match
            }
            set ti [my @GetTypeInfo $i]
            if {$opts(guid) ne ""} {
                if {[string compare -nocase [lindex [$ti @GetTypeAttr -guid] 1] $opts(guid)]} {
                    $ti Release
                    continue
                }
            }
            set varti $ti
            set ret [catch {uplevel 1 $script} result]
            switch -exact -- $ret {
                1 {
                    error $result $::errorInfo $::errorCode
                }
                2 {
                    return -code return $result; # TCL_RETURN
                }
                3 {
                    set i $count; # TCL_BREAK
                }
            }
        }
        return
    }

    method @Register {path {helppath ""}} {
        my variable _ifc
        ::twapi::RegisterTypeLib $_ifc $path $helppath
    }

    method @LoadDispatchPrototypes {} {
        set data [my @Read -type dispatch]
        if {![dict exists $data dispatch]} {
            return
        }

        dict for {guid guiddata} [dict get $data dispatch] {
            foreach type {methods properties} {
                if {[dict exists $guiddata -$type]} {
                    dict for {name namedata} [dict get $guiddata -$type] {
                        dict for {lcid lciddata} $namedata {
                            dict for {invkind proto} $lciddata {
                                ::twapi::dispatch_prototype_set \
                                    $guid $name $lcid $invkind $proto
                            }
                        }
                    }
                }
            }
        }
    }

    method @Text {args} {
        array set opts [::twapi::parseargs args {
            type.arg
            name.arg
        } -maxleftover 0 -nulldefault]

        set text {}
        my @Foreach -type $opts(type) -name $opts(name) ti {
            ::twapi::trap {
                array set attrs [$ti @GetTypeAttr -all]
                set docs [$ti @GetDocumentation -1 -name -docstring]
                set desc "[string totitle $attrs(-typekind)] [::twapi::kl_get $docs -name] $attrs(-guid) - [::twapi::kl_get $docs -docstring]\n"
                switch -exact -- $attrs(-typekind) {
                    record -
                    union  -
                    enum {
                        for {set j 0} {$j < $attrs(-varcount)} {incr j} {
                            array set vardata [$ti @GetVarDesc $j -all]
                            set vardesc "$vardata(-varkind) [::twapi::_resolve_com_type_text $ti $vardata(-datatype)] $vardata(-name)"
                            if {$attrs(-typekind) eq "enum"} {
                                append vardesc " = $vardata(-value) ([::twapi::_resolve_com_type_text $ti $vardata(-valuetype)])"
                            } else {
                                append vardesc " (offset $vardata(-value))"
                            }
                            append desc "\t$vardesc\n"
                        }
                    }
                    alias {
                        append desc "\ttypedef $attrs(-aliasdesc)\n"
                    }
                    module -
                    dispatch -
                    interface {
                        append desc [::twapi::_interface_text $ti]
                    }
                    coclass {
                        for {set j 0} {$j < $attrs(-interfacecount)} {incr j} {
                            set ti2 [$ti @GetRefTypeInfoFromIndex $j]
                            set idesc [$ti2 @GetName]
                            set iflags [$ti @GetImplTypeFlags $j]
                            if {[llength $iflags]} {
                                append idesc " ([join $iflags ,])"
                            }
                            append desc \t$idesc
                            $ti2 Release
                            unset ti2
                        }
                    }
                    default {
                        append desc "Unknown typekind: $attrs(-typekind)\n"
                    }
                }
                append text \n$desc
            } finally {
                $ti Release
                if {[info exists ti2]} {
                    $ti2 Release
                }
            }
        }
        return $text
    }

    method @GenerateCode {args} {
        array set opts [twapi::parseargs args {
            namespace.arg
        } -ignoreunknown]

        if {![info exists opts(namespace)]} {
            set opts(namespace) [string tolower [my @GetName]]
        }

        set data [my @Read {*}$args]
        
        set code {}
        if {[dict exists $data dispatch]} {
            dict for {guid guiddata} [dict get $data dispatch] {
                set dispatch_name [dict get $guiddata -name]
                append code "\n# Dispatch Interface $dispatch_name\n"
                foreach type {methods properties} {
                    if {[dict exists $guiddata -$type]} {
                        append code "# $dispatch_name [string totitle $type]\n"
                        dict for {name namedata} [dict get $guiddata -$type] {
                            dict for {lcid lciddata} $namedata {
                                dict for {invkind proto} $lciddata {
                                    append code [list ::twapi::dispatch_prototype_set \
                                                     $guid $name $lcid $invkind $proto]
                                    append code \n
                                }
                            }
                        }
                    }
                }
            }
        }

        # If namespace specfied as empty string (as opposed to unspecified)
        # do not output a namespace
        if {$opts(namespace) ne "" &&
            ([dict exists $data enum] ||
             [dict exists $data module] ||
             [dict exists $data coclass])
        } {
            append code "\nnamespace eval $opts(namespace) \{"
            append code \n
        }

        if {[dict exists $data module]} {
            dict for {guid guiddata} [dict get $data module] {
                # Some modules may not have constants (-values).
                # We currently only output constants from modules, not functions
                if {[dict exists $guiddata -values]} {
                    set module_name [dict get $guiddata -name]
                    append code "\n    # Module $module_name ($guid)\n"
                    append code "    [list array set $module_name [dict get $guiddata -values]]"
                    append code \n
                }
            }
        }

        if {[dict exists $data enum]} {
            dict for {name def} [dict get $data enum] {
                append code "\n    # Enum $name\n"
                append code "    [list array set $name [dict get $def -values]]"
                append code \n
            }
        }

        if {[dict exists $data coclass]} {
            dict for {guid def} [dict get $data coclass] {
                append code "\n    # Coclass [dict get $def -name]"
                # Look for the default interface so we can remember its GUID.
                # This is necessary for the cases where the Dispatch interface
                # GUID is not available via a TypeInfo interface (e.g.
                # a 64-bit COM component not registered with the 32-bit
                # COM registry)
                set default_dispatch_guid ""
                if {[dict exists $def -interfaces]} {
                    dict for {ifc_guid ifc_def} [dict get $def -interfaces] {
                        if {[dict exists $data dispatch $ifc_guid]} {
                            # Yes it is a dispatch interface
                            # Make sure it is marked as default interface
                            if {[dict exists $ifc_def -flags] &&
                                [dict get $ifc_def -flags] == 1} {
                                set default_dispatch_guid $ifc_guid
                                break
                            }
                        }
                    }
                }
                
                # We assume here that coclass has a default interface
                # which is dispatchable. Else an error will be generated
                # at runtime.
                append code [format {
    twapi::class create %1$s {
        superclass ::twapi::Automation
        constructor {args} {
            set ifc [twapi::com_create_instance "%2$s" -interface IDispatch -raw {*}$args]
            next [twapi::IDispatchProxy new $ifc "%2$s"]
            if {[string length "%3$s"]} {
                my -interfaceguid "%3$s"
            }
        }
    }} [dict get $def -name] $guid $default_dispatch_guid]
                append code \n
            }
        }

        if {$opts(namespace) ne "" &&
            ([dict exists $data enum] ||
             [dict exists $data module] ||
             [dict exists $data coclass])
        } {
            append code "\}"
            append code \n
        }


        return $code
    }

    method @Read {args} {
        array set opts [::twapi::parseargs args {
            type.arg
            name.arg
        } -maxleftover 0 -nulldefault]

        set data [dict create]
        my @Foreach -type $opts(type) -name $opts(name) ti {
            ::twapi::trap {
                array set attrs [$ti @GetTypeAttr -guid -lcid -varcount -fncount -interfacecount -typekind]
                set name [lindex [$ti @GetDocumentation -1 -name] 1]
                # dict set data $attrs(-typekind) $name {}
                switch -exact -- $attrs(-typekind) {
                    record -
                    union  -
                    enum {
                        # For consistency with the coclass and dispatch dict structure
                        # we have a separate key for 'name' even though it is the same
                        # as the dict key
                        dict set data $attrs(-typekind) $name -name $name
                        for {set j 0} {$j < $attrs(-varcount)} {incr j} {
                            array set vardata [$ti @GetVarDesc $j -name -value]
                            dict set data $attrs(-typekind) $name -values $vardata(-name) $vardata(-value)
                        }
                    }
                    alias {
                        # TBD - anything worth importing ?
                    }
                    dispatch {
                        # Load up the functions
                        dict set data $attrs(-typekind) $attrs(-guid) -name $name
                        for {set j 0} {$j < $attrs(-fncount)} {incr j} {
                            array set funcdata [$ti GetFuncDesc $j]
                            if {$funcdata(funckind) != 4} {
                                # Not a dispatch function (4), ignore
                                # TBD - what else could it be if already filtering
                                # typeinfo on dispatch
                                # Vtable set funckind "(vtable $funcdata(-oVft))"
                                ::twapi::debuglog "Unexpected funckind value '$funcdata(funckind)' ignored. funcdata: [array get funcdata]"
                                continue;
                            }
                            
                            set proto [list $funcdata(memid) \
                                           $attrs(-lcid) \
                                           $funcdata(invkind) \
                                           $funcdata(elemdescFunc.tdesc) \
                                           [::twapi::_resolve_params_for_prototype $ti $funcdata(lprgelemdescParam)]]
                            # Param names are needed for named arguments. Index 0 is method name so skip it
                            if {[catch {lappend proto [lrange [$ti GetNames $funcdata(memid)] 1 end]}]} {
                                # Could not get param names
                                lappend proto {}
                            }

                            dict set data "$attrs(-typekind)" \
                                $attrs(-guid) \
                                -methods \
                                [$ti @GetName $funcdata(memid)] \
                                $attrs(-lcid) \
                                $funcdata(invkind) \
                                $proto
                        }
                        # Load up the properties
                        for {set j 0} {$j < $attrs(-varcount)} {incr j} {
                            array set vardata [$ti GetVarDesc $j]
                            # We will add both propput and propget.
                            # propget:
                            dict set data "$attrs(-typekind)" \
                                $attrs(-guid) \
                                -properties \
                                [$ti @GetName $vardata(memid)] \
                                $attrs(-lcid) \
                                2 \
                                [list $vardata(memid) $attrs(-lcid) 2 $vardata(elemdescVar.tdesc) {} {}]

                            # TBD - mock up the parameters for the property set
                            # Single parameter corresponding to return type of
                            # property. Param list is of the form
                            # {PARAM1 PARAM2} where PARAM is {TYPE {FLAGS ?DEFAULT}}
                            # So param list with one param is
                            # {{TYPE {FLAGS ?DEFAULT?}}}
                            # propput:
                            if {! ($vardata(wVarFlags) & 1)} {
                                # Not read-only
                                dict set data "$attrs(-typekind)" \
                                    $attrs(-guid) \
                                    -properties \
                                    [$ti @GetName $vardata(memid)] \
                                    $attrs(-lcid) \
                                    4 \
                                    [list $vardata(memid) $attrs(-lcid) 4 24 [list [list $vardata(elemdescVar.tdesc) [list 1]]] {}]
                            }
                        }
                    }


                    module {
                        dict set data $attrs(-typekind) $attrs(-guid) -name $name
                        # TBD - Load up the functions

                        # Now load up the variables
                        for {set j 0} {$j < $attrs(-varcount)} {incr j} {
                            array set vardata [$ti @GetVarDesc $j -name -value]
                            dict set data $attrs(-typekind) $attrs(-guid) -values $vardata(-name) $vardata(-value)
                        }
                    }

                    interface {
                        # TBD
                    }
                    coclass {
                        dict set data "coclass" $attrs(-guid) -name $name
                        for {set j 0} {$j < $attrs(-interfacecount)} {incr j} {
                            set ti2 [$ti @GetRefTypeInfoFromIndex $j]
                            set iflags [$ti GetImplTypeFlags $j]
                            set iguid [twapi::kl_get [$ti2 GetTypeAttr] guid]
                            set iname [$ti2 @GetName]
                            $ti2 Release
                            unset ti2; # So finally clause does not relese again on error

                            dict set data "coclass" $attrs(-guid) -interfaces $iguid -name $iname
                            dict set data "coclass" $attrs(-guid) -interfaces $iguid -flags $iflags
                        }
                    }
                    default {
                        # TBD
                    }
                }
            } finally {
                $ti Release
                if {[info exists ti2]} {
                    $ti2 Release
                }
            }
        }
        return $data
    }

    twapi_exportall
}

# ITypeComp
#----------
twapi::class create ::twapi::ITypeCompProxy {
    superclass ::twapi::IUnknownProxy

    method Bind {name lhash flags} {
        my variable _ifc
        return [::twapi::ITypeComp_Bind $_ifc $name $lhash $flags]
    }

    # Returns empty list if bind not found
    method @Bind {name flags {lcid 0}} {
        ::twapi::trap {
            set binding [my Bind $name [::twapi::LHashValOfName $lcid $name] $flags]
        } onerror {TWAPI_WIN32 0x80028ca0} {
            # Found but type mismatch (flags not correct)
            return {}
        }

        lassign $binding type data tifc
        return [list $type $data [::twapi::make_interface_proxy $tifc]]
    }

    twapi_exportall
}

# IEnumVARIANT
#-------------

twapi::class create ::twapi::IEnumVARIANTProxy {
    superclass ::twapi::IUnknownProxy

    method Next {count {value_only 0}} {
        my variable _ifc
        return [::twapi::IEnumVARIANT_Next $_ifc $count $value_only]
    }
    method Clone {} {
        my variable _ifc
        return [::twapi::IEnumVARIANT_Clone $_ifc]
    }
    method @Clone {} {
        return [::twapi::make_interface_proxy [my Clone]]
    }
    method Reset {} {
        my variable _ifc
        return [::twapi::IEnumVARIANT_Reset $_ifc]
    }
    method Skip {count} {
        my variable _ifc
        return [::twapi::IEnumVARIANT_Skip $_ifc $count]
    }

    twapi_exportall
}

# Automation
#-----------
twapi::class create ::twapi::Automation {

    # Caller gives up ownership of proxy in all cases, even errors.
    # $proxy will eventually be Release'ed. If caller wants to keep
    # a reference to it, it must do an *additional* AddRef on it to
    # keep it from going away when the Automation object releases it.
    constructor {proxy {lcid 0}} {
        my variable _proxy _lcid  _sinks _connection_pts

        set type [$proxy @Type]
        if {$type ne "IDispatch" && $type ne "IDispatchEx"} {
            $proxy Release;     # Even on error, responsible for releasing
            error "Automation objects do not support interfaces of type '$type'"
        }
        if {$type eq "IDispatchEx"} {
            my variable _have_dispex
            # If _have_dispex variable
            #   - does not exist, have not tried to get IDispatchEx yet
            #   - is 0, have tried but failed
            #   - is 1, already have IDispatchEx
            set _have_dispex 1
        }

        set _proxy $proxy
        set _lcid $lcid
        array set _sinks {}
        array set _connection_pts {}
    }

    destructor {
        my variable _proxy  _sinks

        # Release sinks, connection points
        foreach sinkid [array names _sinks] {
            my -unbind $sinkid
        }

        if {[info exists _proxy]} {
            $_proxy Release
        }
        return
    }

    # Intended to be called only from another method. Not directly.
    # Does an uplevel 2 to get to application context.
    # On failures, retries with IDispatchEx interface
    # TBD - get rid of this uplevel business by having internal
    # callers to equivalent of "uplevel 1 my _invoke ...
    method _invoke {name invkinds params args} {
        my variable  _proxy  _lcid

        if {[$_proxy @Null?]} {
            error "Attempt to invoke method $name on NULL COM object"
        }

        array set opts [twapi::parseargs args {
            raw.bool
            namedargs.arg
        } -nulldefault -maxleftover 0]

        ::twapi::trap {
            set vtval [uplevel 2 [list $_proxy @Invoke $name $invkinds $_lcid $params $opts(namedargs)]]
            if {$opts(raw)} {
                return $vtval
            } else {
                return [::twapi::variant_value $vtval 0 0 $_lcid]
            }
        } onerror {} {
            # TBD - should we only drop down below to check for IDispatchEx
            # for specific error codes. Right now we do it for all.
            set erinfo $::errorInfo
            set ercode $::errorCode
            set ermsg [::twapi::trapresult]
        }

        # We plan on trying to get a IDispatchEx interface in case
        # the method/property is the "expando" type
        my variable  _have_dispex
        if {[info exists _have_dispex]} {
            # We have already tried for IDispatchEx, either successfully
            # or not. Either way, no need to try again
            error $ermsg $erinfo $ercode
        }

        # Try getting a IDispatchEx interface
        if {[catch {$_proxy @QueryInterface IDispatchEx 1} proxy_ex] ||
            $proxy_ex eq ""} {
            set _have_dispex 0
            error $ermsg $erinfo $ercode
        }

        set _have_dispex 1
        $_proxy Release
        set _proxy $proxy_ex
        
        # Retry with the IDispatchEx interface
        set vtval [uplevel 2 [list $_proxy @Invoke $name $invkinds $_lcid $params $opts(namedargs)]]
        if {$opts(raw)} {
            return $vtval
        } else {
            return [::twapi::variant_value $vtval 0 0 $_lcid]
        }
    }

    method -get {name args} {
        return [my _invoke $name [list 2] $args]
    }

    method -set {name args} {
        return [my _invoke $name [list 4] $args]
    }

    method -call {name args} {
        return [my _invoke $name [list 1] $args]
    }

    method -callnamedargs {name args} {
        return [my _invoke $name [list 1] {} -namedargs $args]
    }

    # Need a wrapper around _invoke in order for latter's uplevel 2
    # to work correctly
    # TBD - document, test
    method -invoke {name invkinds params args} {
        return [my _invoke $name $invkinds $params {*}$args]
    }

    method -destroy {} {
        my destroy
    }

    method -isnull {} {
        my variable _proxy
        return [$_proxy @Null?]
    }

    method -default {} {
        my variable _proxy _lcid
        return [::twapi::variant_value [$_proxy Invoke ""] 0 0 $_lcid]
    }

    # Caller must call release on the proxy
    method -proxy {} {
        my variable _proxy
        $_proxy AddRef
        return $_proxy
    }

    # Only for debugging
    method -proxyrefcounts {} {
        my variable _proxy
        return [$_proxy DebugRefCounts]
    }

    # Returns the raw interface. Caller must call IUnknownRelease on it
    # iff addref is passed as true (default)
    method -interface {{addref 1}} {
        my variable _proxy
        return [$_proxy @Interface $addref]
    }

    # Validates internal structures
    method -validate {} {
        twapi::ValidateIUnknown [my -interface 0]
    }

    # Set/return the GUID for the interface
    method -interfaceguid {{guid ""}} {
        my variable _proxy
        return [$_proxy @SetGuid $guid]
    }

    # Return the disp id for a method/property
    method -dispid {name} {
        my variable _proxy
        return [$_proxy @GetIDOfOneName $name]
    }

    # Prints methods in an interface
    method -print {} {
        my variable _proxy
        ::twapi::dispatch_print $_proxy
    }

    method -with {subobjlist args} {
        # $obj -with SUBOBJECTPATHLIST arguments
        # where SUBOBJECTPATHLIST is list each element of which is
        # either a property or a method of the previous element in
        # the list. The element may itself be a list in which case
        # the first element is the property/method and remaining
        # are passed to it
        #
        # Note that 'arguments' may themselves be comobj subcommands!
        set next [self]
        set releaselist [list ]
        ::twapi::trap {
            while {[llength $subobjlist]} {
                set nextargs [lindex $subobjlist 0]
                set subobjlist [lrange $subobjlist 1 end]
                set next [uplevel 1 [list $next] $nextargs]
                lappend releaselist $next
            }
            # We use uplevel here because again we want to run in caller
            # context 
            return [uplevel 1 [list $next] $args]
        } finally {
            foreach next $releaselist {
                $next -destroy
            }
        }
    }

    method -iterate {args} {
        my variable _lcid

        array set opts [::twapi::parseargs args {
            cleanup
        }]

        if {[llength $args] < 2} {
            error "Syntax: COMOBJ -iterate ?options? VARNAME SCRIPT"
        }
        upvar 1 [lindex $args 0] var
        set script [lindex $args 1]

        # TBD - need more comprehensive test cases when return/break/continue
        # are used in the script

        # First get IEnumVariant iterator using the _NewEnum method
        # TBD - As per MS OLE Automation spec, it appears _NewEnum
        # MUST have dispid -4. Can we use this information when
        # this object does not have an associated interface guid or
        # when no prototype is available ?
        set enumerator [my -get _NewEnum]
        # This gives us an IUnknown.
        ::twapi::trap {
            # Convert the IUnknown to IEnumVARIANT
            set iter [$enumerator @QueryInterface IEnumVARIANT]
            if {! [$iter @Null?]} {
                set more 1
                while {$more} {
                    # Get the next item from iterator
                    set next [$iter Next 1]
                    lassign $next more values
                    if {[llength $values]} {
                        set var [::twapi::variant_value [lindex $values 0] 0 0 $_lcid]
                        set ret [catch {uplevel 1 $script} msg options]
                        switch -exact -- $ret {
                            0 -
                            4 {
                                # Body executed successfully, or invoked continue
                                if {$opts(cleanup)} {
                                    $var destroy
                                }
                            }
                            3 {
                                if {$opts(cleanup)} {
                                    $var destroy
                                }
                                set more 0; # TCL_BREAK
                            }
                            1 -
                            2 -
                            default {
                                if {$opts(cleanup)} {
                                    $var destroy
                                }
                                dict incr options -level
                                return -options $options $msg
                            }

                        }
                    }
                }
            }
        } finally {
            $enumerator Release
            if {[info exists iter] && ![$iter @Null?]} {
                $iter Release
            }
        }
        return
    }

    method -bind {script} {
        my variable   _proxy   _sinks    _connection_pts

        # Get the coclass typeinfo and  locate the source interface
        # within it and retrieve disp id mappings
        ::twapi::trap {
            set coti [$_proxy @GetCoClassTypeInfo]

            # $coti is the coclass information. Get dispids for the default
            # source interface for events and its guid
            set srcti [$coti @GetDefaultSourceTypeInfo]
            array set srcinfo [$srcti @GetTypeAttr -memidmap -guid]

            # TBD - implement IConnectionPointContainerProxy
            # Now we need to get the actual connection point itself
            set container [$_proxy QueryInterface IConnectionPointContainer]
            set connpt_ifc [::twapi::IConnectionPointContainer_FindConnectionPoint $container $srcinfo(-guid)]

            # Finally, create our sink object
            # TBD - need to make sure Automation object is not deleted or
            # should the callback itself check?
            # TBD - what guid should we be passing? CLSID or IID ?
            set sink_ifc [::twapi::Twapi_ComServer $srcinfo(-guid) $srcinfo(-memidmap) [list ::twapi::_eventsink_callback [self] $script]]

            # OK, we finally have everything we need. Tell the event source
            set sinkid [::twapi::IConnectionPoint_Advise $connpt_ifc $sink_ifc]
            
            set _sinks($sinkid) $sink_ifc
            set _connection_pts($sinkid) $connpt_ifc
            return $sinkid
        } onerror {} {
            # These are released only on error as otherwise they have
            # to be kept until unbind time
            foreach ifc {connpt_ifc sink_ifc} {
                if {[info exists $ifc] && [set $ifc] ne ""} {
                    ::twapi::IUnknown_Release [set $ifc]
                }
            }
            twapi::rethrow
        } finally {
            # In all cases, release any interfaces we created
            # Note connpt_ifc and sink_ifc are released at unbind time except
            # on error
            foreach obj {coti srcti} {
                if {[info exists $obj]} {
                    [set $obj] Release
                }
            }
            if {[info exists container]} {
                ::twapi::IUnknown_Release $container
            }
        }
    }

    method -unbind {sinkid} {
        my variable   _proxy   _sinks    _connection_pts

        if {[info exists _connection_pts($sinkid)]} {
            ::twapi::IConnectionPoint_Unadvise $_connection_pts($sinkid) $sinkid
            unset _connection_pts($sinkid)
        }

        if {[info exists _sinks($sinkid)]} {
            ::twapi::IUnknown_Release $_sinks($sinkid)
            unset _sinks($sinkid)
        }
        return
    }

    method -securityblanket {args} {
        my variable _proxy
        if {[llength $args]} {
            $_proxy @SetSecurityBlanket [lindex $args 0]
            return
        } else {
            return [$_proxy @GetSecurityBlanket]
        }
    }

    method -lcid {{lcid ""}} {
        my variable _lcid
        if {$lcid ne ""} {
            if {![string is integer -strict $lcid]} {
                error "Invalid LCID $lcid"
            }
            set _lcid $lcid
        }
        return $_lcid
    }

    method unknown {name args} {
        # Try to figure out whether it is a property or method

        # We have to figure out if it is a property get, property put
        # or a method. We make a guess based on number of parameters.
        # We specify an order to try based on this. The invoke will try
        # all invocations in that order.
        # TBD - what about propputref ?
        set nargs [llength $args]
        if {$nargs == 0} {
            # No arguments, cannot be propput. Try propget and method
            set invkinds [list 2 1]
        } elseif {$nargs == 1} {
            # One argument, likely propput, method, propget
            set invkinds [list 4 1 2]
        } else {
            # Multiple arguments, likely method, propput, propget
            set invkinds [list 1 4 2]
        }

        # TBD - should this do an uplevel ?
        return [my _invoke $name $invkinds $args]
    }

    twapi_exportall
}

#
# Singleton NULL comobj object. We want to override default destroy methods
# to prevent object from being destroyed. This is a backward compatibility
# hack and not fool proof since the command could just be renamed away.
twapi::class create twapi::NullAutomation {
    superclass twapi::Automation
    constructor {} {
        next [twapi::make_interface_proxy {0 IDispatch}]
    }
    method -destroy {}  {
        # Silently ignore
    }
    method destroy {}  {
        # Silently ignore
    }
    twapi_exportall
}

twapi::NullAutomation create twapi::comobj_null
# twapi::Automation create twapi::comobj_null [twapi::make_interface_proxy {0 IDispatch}]

proc twapi::_comobj_cleanup {} {
    foreach obj [comobj_instances] {
        $obj destroy
    }
}

# In order for servers to release objects properly, the IUnknown interface
# must have the same security settings as were used in the object creation
# call. This is a helper for that.
proc twapi::_com_set_iunknown_proxy {ifc blanket} {
    set iunk [Twapi_IUnknown_QueryInterface $ifc [_iid_iunknown] IUnknown]
    trap {
        CoSetProxyBlanket $iunk {*}$blanket
    } finally {
        IUnknown_Release $iunk
    }
}


twapi::proc* twapi::_init_authnames {} {
    variable _com_authsvc_to_name 
    variable _com_name_to_authsvc
    variable _com_impersonation_to_name
    variable _com_name_to_impersonation
    variable _com_authlevel_to_name
    variable _com_name_to_authlevel

    set _com_authsvc_to_name {0 none 9 negotiate 10 ntlm 14 schannel 16 kerberos 0xffffffff default}
    set _com_name_to_authsvc [swapl $_com_authsvc_to_name]
    set _com_name_to_impersonation {default 0 anonymous 1 identify 2 impersonate 3 delegate 4}
    set _com_impersonation_to_name [swapl $_com_name_to_impersonation]
    set _com_name_to_authlevel {default 0 none 1 connect 2 call 3 packet 4 packetintegrity 5 privacy 6}
    set _com_authlevel_to_name [swapl $_com_name_to_authlevel]
} {
}

twapi::proc* twapi::_com_authsvc_to_name {authsvc} {
    _init_authnames
} {
    variable _com_authsvc_to_name
    return [dict* $_com_authsvc_to_name $authsvc]
}

twapi::proc* twapi::_com_name_to_authsvc {name} {
    _init_authnames
} {
    variable _com_name_to_authsvc
    if {[string is integer -strict $name]} {
        return $name
    }
    return [dict! $_com_name_to_authsvc $name]
}

twapi::proc* twapi::_com_authlevel_to_name {authlevel} {
    _init_authnames
} {
    variable _com_authlevel_to_name
    return [dict* $_com_authlevel_to_name $authlevel]
}

twapi::proc* twapi::_com_name_to_authlevel {name} {
    _init_authnames
} {
    variable _com_name_to_authlevel
    if {[string is integer -strict $name]} {
        return $name
    }
    return [dict! $_com_name_to_authlevel $name]
}


twapi::proc* twapi::_com_impersonation_to_name {imp} {
    _init_authnames
} {
    variable _com_impersonation_to_name
    return [dict* $_com_impersonation_to_name $imp]
}

twapi::proc* twapi::_com_name_to_impersonation {name} {
    _init_authnames
} {
    variable _com_name_to_impersonation
    if {[string is integer -strict $name]} {
        return $name
    }
    return [dict! $_com_name_to_impersonation $name]
}

#################################################################
# COM server implementation
# WARNING: do not use any fancy TclOO features because it has to
# run under 8.5/metoo as well
# TBD - test scripts?

twapi::class create twapi::ComFactory {
    constructor {clsid member_map create_command_prefix} {
        my variable _clsid _create_command_prefix _member_map _ifc

        set _clsid $clsid
        set _member_map $member_map
        set _create_command_prefix $create_command_prefix

        set _ifc [twapi::Twapi_ClassFactory $_clsid [list [self] _create_instance]]
    }

    destructor {
        # TBD - what happens if factory is destroyed while objects still
        # exist ?
        # App MUST explicitly destroy objects before exiting
        my variable _class_registration_id
        if {[info exists _class_registration_id]} {
            twapi::CoRevokeClassObject $_class_registration_id
        }
    }

    # Called from Twapi_ClassFactory_CreateInstance to create a new object
    # Should not be called from elsewhere
    method _create_instance {iid} {
        my variable _create_command_prefix _member_map
        # Note [list {*}$foo] != $foo - consider when foo contains a ";"
        set obj_prefix [uplevel #0 [list {*}$_create_command_prefix]]
        twapi::trap {
            # Since we are not holding on to this interface ourselves,
            # we can pass it on without AddRef'ing it
            return [twapi::Twapi_ComServer $iid $_member_map $obj_prefix]
        } onerror {} {
            $obj_prefix destroy
            twapi::rethrow
        }
    }

    method register {args} {
        my variable _clsid _create_command_prefix _member_map _ifc _class_registration_id
        twapi::parseargs args {
            {model.arg any}
        } -setvars -maxleftover 0
        set model_flags 0
        foreach m $model {
            switch -exact -- $m {
                any           {twapi::setbits model_flags 20}
                localserver   {twapi::setbits model_flags 4}
                remoteserver  {twapi::setbits model_flags 16}
                default {twapi::badargs! "Invalid COM class model '$m'"}
            }
        }
        
        # 0x6 -> REGCLS_MULTI_SEPARATE | REGCLS_SUSPENDED
        set _class_registration_id [twapi::CoRegisterClassObject $_clsid $_ifc $model_flags 0x6]
        return
    }
    
    export _create_instance
}

proc twapi::comserver_factory {clsid member_map command_prefix {name {}}} {
    if {$name ne ""} {
        uplevel 1 [list [namespace current]::ComFactory create $name $clsid $member_map $command_prefix]
    } else {
        uplevel 1 [list [namespace current]::ComFactory new $clsid $member_map $command_prefix]
    }
}

proc twapi::start_factories {{cmd {}}} {
    # TBD - what if no class objects ?
    CoResumeClassObjects

    if {[llength $cmd]} {
        # TBD - normalize $cmd so to run in right namespace etc.
        trace add variable [namspace current]::com_shutdown_signal write $cmd
        return
    }

    # This is set from the C code when we are not serving up any
    # COM objects (either event callbacks or com servers)
    vwait [namespace current]::com_shutdown_signal
}

proc twapi::suspend_factories {} {
    CoSuspendClassObjects
}

proc twapi::resume_factories {} {
    CoResumeClassObjects
}

proc twapi::install_coclass_script {progid clsid version script_path args} {
    # Need to extract params so we can prefix script name
    set saved_args $args
    array set opts [parseargs args {
        params.arg
    } -ignoreunknown]

    set script_path [file normalize $script_path]

    # Try to locate the wish executable to run the component
    if {[info commands wm] eq ""} {
        set dir [file dirname [info nameofexecutable]]
        set wishes [glob -nocomplain -directory $dir wish*.exe]
        if {[llength $wishes] == 0} {
            error "Could not locate wish program."
        }
        set wish [lindex $wishes 0]
    } else {
        # We are running wish already
        set wish [info nameofexecutable]
    }

    set exe_path [file nativename [file attributes $wish -shortname]]

    set params "\"$script_path\""
    if {[info exists opts(params)]} {
        append params " $params"
    }
    return [install_coclass $progid $clsid $version $exe_path {*}$args -outproc -params $params]
}

proc twapi::install_coclass {progid clsid version path args} {
    array set opts [twapi::parseargs args {
        {scope.arg user {user system}}
        appid.arg
        appname.arg
        inproc
        outproc
        service
        params.arg
        name.arg
    } -maxleftover 0]

    switch [tcl::mathop::+ $opts(inproc) $opts(outproc) $opts(service)] {
        0 {
            # Need to figure out the type
            switch [file extension $path] {
                .exe { set opts(outproc) 1 }
                .ocx -
                .dll { set opts(inproc) 1 }
                default { set opts(service) 1 }
            }
        }
        1 {}
        default {
            badargs! "Only one of -inproc, -outproc or -service may be specified"
        }
    }

    if {(! [string is integer -strict $version]) || $version <= 0} {
        twapi::badargs! "Invalid version '$version'. Must be a positive integer"
    }
    if {![regexp {^[[:alpha:]][[:alnum:]]*\.[[:alpha:]][[:alnum:]]*$} $progid]} {
        badargs! "Invalid PROGID syntax '$progid'"
    }
    set clsid [canonicalize_guid $clsid]
    if {![info exists opts(appid)]} {
        # This is what dcomcnfg and oleview do - default to the CLSID
        set opts(appid) $clsid
    } else {
        set opts(appid) [canonicalize_guid $opts(appid)]
    }

    if {$opts(scope) eq "user"} {
        if {$opts(service)} {
            twapi::badargs! "Option -service cannot be specified if -scope is \"user\""
        }
        set regtop HKEY_CURRENT_USER
    } else {
        set regtop HKEY_LOCAL_MACHINE
    }

    set progid_path "$regtop\\Software\\Classes\\$progid"
    set clsid_path "$regtop\\Software\\Classes\\CLSID\\$clsid"
    set appid_path "$regtop\\Software\\Classes\\AppID\\$opts(appid)"

    if {$opts(service)} {
        # TBD
        badargs! "Option -service is not implemented"
    } elseif {$opts(outproc)} {
        if {[info exists opts(params)]} {
            registry set "$clsid_path\\LocalServer32" "" "\"[file nativename [file normalize $path]]\" $opts(params)"
        } else {
            registry set "$clsid_path\\LocalServer32" "" "\"[file nativename [file normalize $path]]\""
        }
        # TBD - We do not quote path for ServerExecutable, should we ?
        registry set "$clsid_path\\LocalServer32" "ServerExecutable" [file nativename [file normalize $path]]
    } else {
        # TBD - We do not quote path here either, should we ?
        registry set "$clsid_path\\InprocServer32" "" [file nativename [file normalize $path]]
    }
    
    registry set "$clsid_path\\ProgID" "" "$progid.$version"
    registry set "$clsid_path\\VersionIndependentProgID" "" $progid

    # Set the registry under the progid and progid.version
    registry set "$progid_path\\CLSID" "" $clsid
    registry set "$progid_path\\CurVer" "" "$progid.$version"
    if {[info exists opts(name)]} {
        registry set $progid_path "" $opts(name)
    }

    append progid_path ".$version"
    registry set "$progid_path\\CLSID" "" $clsid
    if {[info exists opts(name)]} {
        registry set $progid_path "" $opts(name)
    }
    
    registry set $clsid_path "AppID" $opts(appid)
    registry set $appid_path;   # Always create the key even if nothing below
    if {[info exists opts(appname)]} {
        registry set $appid_path "" $opts(appname)
    }
    
    if {$opts(service)} {
        registry set $appid_path "LocalService" $path
        if {[info exists opts(params)]} {
            registry set $appid_path "ServiceParameters" $opts(params)
        }
    }

    return
}

proc twapi::uninstall_coclass {progid args} {
    # Note "CLSID" itself is a valid ProgID (it has a CLSID key below it)
    # Also we want to protect against horrible errors that blow away
    # entire branches if progid is empty, wrong value, etc.
    # So only work with keys of the form X.X
    if {![regexp {^[[:alpha:]][[:alnum:]]*\.[[:alpha:]][[:alnum:]]*$} $progid]} {
        badargs! "Invalid PROGID syntax '$progid'"
    }

    # Do NOT want to delete the CLSID key by mistake. Note below checks
    # will not protect against this since they will return a valid value 
    # if progid is "CLSID" since that has a CLSID key below it as well.
    if {[string equal -nocase $progid CLSID]} {
        badargs! "Attempt to delete protected key 'CLSID'"
    }

    array set opts [twapi::parseargs args {
        {scope.arg user {user system}}
        keepappid
    } -maxleftover 0]

    switch -exact -- $opts(scope) {
        user { set regtop HKEY_CURRENT_USER }
        system { set regtop HKEY_LOCAL_MACHINE }
        default {
            badargs! "Invalid class registration scope '$opts(scope)'. Must be 'user' or 'system'"
        }
    }

    if {0} {
        # Do NOT use this. If running under elevated, it will ignore
        # HKEY_CURRENT_USER.
        set clsid [progid_to_clsid $progid]; # Also protects against bogus progids
    } else {
        set clsid [registry get "$regtop\\Software\\Classes\\$progid\\CLSID" ""]
    }

    # Should not be empty at this point but do not want to delete the 
    # whole Classes tree in case progid or clsid are empty strings
    # because of some bug! That would be an epic disaster so try and
    # protect.
    if {$clsid eq ""} {
        badargs! "CLSID corresponding to PROGID '$progid' is empty"
    }
    
    # See if we need to delete the linked current version
    if {! [catch {
        registry get "$regtop\\Software\\Classes\\$progid\\CurVer" ""
    } curver]} {
        if {[string match -nocase ${progid}.* $curver]} {
            registry delete "$regtop\\Software\\Classes\\$curver"
        }
    }

    # See if we need to delete the APPID
    if {! $opts(keepappid)} {
        if {! [catch {
            registry get "$regtop\\Software\\Classes\\CLSID\\$clsid" "AppID"
        } appid]} {
            # Validate it is a real GUID
            if {![catch {canonicalize_guid $appid}]} {
                registry delete "$regtop\\Software\\Classes\\AppID\\$appid"
            }
        }
    }

    # Finally delete the keys and hope we have not trashed the system
    registry delete "$regtop\\Software\\Classes\\CLSID\\$clsid"
    registry delete "$regtop\\Software\\Classes\\$progid"

    return
}