QuickWho

Check-in [102c87e26e]
Login

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:Cleanup of unused libs
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:102c87e26e8826386b0a2c2b93d4d9e18a020434
User & Date: kevin 2017-04-24 02:33:00
Context
2017-04-25
02:30
Version info for Windows check-in: 694d80fa97 user: kevin tags: trunk
2017-04-24
02:33
Cleanup of unused libs check-in: 102c87e26e user: kevin tags: trunk
02:30
Revbump for new release on Mac, Windows check-in: 08824053a9 user: kevin tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Deleted winlibs/tdom/pkgIndex.tcl.

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

Deleted winlibs/tdom/tdom.tcl.

     1         -#----------------------------------------------------------------------------
     2         -#   Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com)
     3         -#----------------------------------------------------------------------------
     4         -#
     5         -#   $Id$
     6         -#
     7         -#
     8         -#   The higher level functions of tDOM written in plain Tcl.
     9         -#
    10         -#
    11         -#   The contents of this file are subject to the Mozilla Public License
    12         -#   Version 1.1 (the "License"); you may not use this file except in
    13         -#   compliance with the License. You may obtain a copy of the License at
    14         -#   http://www.mozilla.org/MPL/
    15         -#
    16         -#   Software distributed under the License is distributed on an "AS IS"
    17         -#   basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
    18         -#   License for the specific language governing rights and limitations
    19         -#   under the License.
    20         -#
    21         -#   The Original Code is tDOM.
    22         -#
    23         -#   The Initial Developer of the Original Code is Jochen Loewer
    24         -#   Portions created by Jochen Loewer are Copyright (C) 1998, 1999
    25         -#   Jochen Loewer. All Rights Reserved.
    26         -#
    27         -#   Contributor(s):
    28         -#       Rolf Ade (rolf@pointsman.de):   'fake' nodelists/live childNodes
    29         -#
    30         -#   written by Jochen Loewer
    31         -#   April, 1999
    32         -#
    33         -#----------------------------------------------------------------------------
    34         -
    35         -package require tdom 
    36         -
    37         -#----------------------------------------------------------------------------
    38         -#   setup namespaces for additional Tcl level methods, etc.
    39         -#
    40         -#----------------------------------------------------------------------------
    41         -namespace eval ::dom {
    42         -    namespace eval  domDoc {
    43         -    }
    44         -    namespace eval  domNode {
    45         -    }
    46         -    namespace eval  DOMImplementation {
    47         -    }
    48         -    namespace eval  xpathFunc {
    49         -    }
    50         -    namespace eval  xpathFuncHelper {
    51         -    }
    52         -}
    53         -
    54         -namespace eval ::tDOM { 
    55         -    variable extRefHandlerDebug 0
    56         -    variable useForeignDTD ""
    57         -
    58         -    namespace export xmlOpenFile xmlReadFile extRefHandler baseURL
    59         -}
    60         -
    61         -#----------------------------------------------------------------------------
    62         -#   hasFeature (DOMImplementation method)
    63         -#
    64         -#
    65         -#   @in  url    the URL, where to get the XML document
    66         -#
    67         -#   @return     document object
    68         -#   @exception  XML parse errors, ...
    69         -#
    70         -#----------------------------------------------------------------------------
    71         -proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } {
    72         -
    73         -    switch $feature {
    74         -        xml -
    75         -        XML {
    76         -            if {($version == "") || ($version == "1.0")} {
    77         -                return 1
    78         -            }
    79         -        }
    80         -    }
    81         -    return 0
    82         -
    83         -}
    84         -
    85         -#----------------------------------------------------------------------------
    86         -#   load (DOMImplementation method)
    87         -#
    88         -#       requests a XML document via http using the given URL and
    89         -#       builds up a DOM tree in memory returning the document object
    90         -#
    91         -#
    92         -#   @in  url    the URL, where to get the XML document
    93         -#
    94         -#   @return     document object
    95         -#   @exception  XML parse errors, ...
    96         -#
    97         -#----------------------------------------------------------------------------
    98         -proc ::dom::DOMImplementation::load { dom url } {
    99         -
   100         -    error "Sorry, load method not implemented yet!"
   101         -
   102         -}
   103         -
   104         -#----------------------------------------------------------------------------
   105         -#   isa (docDoc method, for [incr tcl] compatibility)
   106         -#
   107         -#
   108         -#   @in  className
   109         -#
   110         -#   @return         1 iff inherits from the given class
   111         -#
   112         -#----------------------------------------------------------------------------
   113         -proc ::dom::domDoc::isa { doc className } {
   114         -
   115         -    if {$className == "domDoc"} {
   116         -        return 1
   117         -    }
   118         -    return 0
   119         -}
   120         -
   121         -#----------------------------------------------------------------------------
   122         -#   info (domDoc method, for [incr tcl] compatibility)
   123         -#
   124         -#
   125         -#   @in  subcommand
   126         -#   @in  args
   127         -#
   128         -#----------------------------------------------------------------------------
   129         -proc ::dom::domDoc::info { doc subcommand args } {
   130         -
   131         -    switch $subcommand {
   132         -        class {
   133         -            return "domDoc"
   134         -        }
   135         -        inherit {
   136         -            return ""
   137         -        }
   138         -        heritage {
   139         -            return "domDoc {}"
   140         -        }
   141         -        default {
   142         -            error "domDoc::info subcommand $subcommand not yet implemented!"
   143         -        }
   144         -    }
   145         -}
   146         -
   147         -#----------------------------------------------------------------------------
   148         -#   importNode (domDoc method)
   149         -#
   150         -#       Document Object Model (Core) Level 2 method
   151         -#
   152         -#
   153         -#   @in  subcommand
   154         -#   @in  args
   155         -#
   156         -#----------------------------------------------------------------------------
   157         -proc ::dom::domDoc::importNode { doc importedNode deep } {
   158         -
   159         -    if {$deep || ($deep == "-deep")} {
   160         -        set node [$importedNode cloneNode -deep]
   161         -    } else {
   162         -        set node [$importedNode cloneNode]
   163         -    }
   164         -    return $node
   165         -}
   166         -
   167         -#----------------------------------------------------------------------------
   168         -#   isa (domNode method, for [incr tcl] compatibility)
   169         -#
   170         -#
   171         -#   @in  className
   172         -#
   173         -#   @return         1 iff inherits from the given class
   174         -#
   175         -#----------------------------------------------------------------------------
   176         -proc ::dom::domNode::isa { doc className } {
   177         -
   178         -    if {$className == "domNode"} {
   179         -        return 1
   180         -    }
   181         -    return 0
   182         -}
   183         -
   184         -#----------------------------------------------------------------------------
   185         -#   info (domNode method, for [incr tcl] compatibility)
   186         -#
   187         -#
   188         -#   @in  subcommand
   189         -#   @in  args
   190         -#
   191         -#----------------------------------------------------------------------------
   192         -proc ::dom::domNode::info { doc subcommand args } {
   193         -
   194         -    switch $subcommand {
   195         -        class {
   196         -            return "domNode"
   197         -        }
   198         -        inherit {
   199         -            return ""
   200         -        }
   201         -        heritage {
   202         -            return "domNode {}"
   203         -        }
   204         -        default {
   205         -            error "domNode::info subcommand $subcommand not yet implemented!"
   206         -        }
   207         -    }
   208         -}
   209         -
   210         -#----------------------------------------------------------------------------
   211         -#   isWithin (domNode method)
   212         -#
   213         -#       tests, whether a node object is nested below another tag
   214         -#
   215         -#
   216         -#   @in  tagName  the nodeName of an elment node
   217         -#
   218         -#   @return       1 iff node is nested below a element with nodeName tagName
   219         -#                 0 otherwise
   220         -#
   221         -#----------------------------------------------------------------------------
   222         -proc ::dom::domNode::isWithin { node tagName } {
   223         -
   224         -    while {[$node parentNode] != ""} {
   225         -        set node [$node parentNode]
   226         -        if {[$node nodeName] == $tagName} {
   227         -            return 1
   228         -        }
   229         -    }
   230         -    return 0
   231         -}
   232         -
   233         -#----------------------------------------------------------------------------
   234         -#   tagName (domNode method)
   235         -#
   236         -#       same a nodeName for element interface
   237         -#
   238         -#----------------------------------------------------------------------------
   239         -proc ::dom::domNode::tagName { node } {
   240         -
   241         -    if {[$node nodeType] == "ELEMENT_NODE"} {
   242         -        return [$node nodeName]
   243         -    }
   244         -    return -code error "NOT_SUPPORTED_ERR not an element!"
   245         -}
   246         -
   247         -#----------------------------------------------------------------------------
   248         -#   simpleTranslate (domNode method)
   249         -#
   250         -#       applies simple translation rules similar to Cost's simple
   251         -#       translations to a node
   252         -#
   253         -#
   254         -#   @in  output_var
   255         -#   @in  trans_specs
   256         -#
   257         -#----------------------------------------------------------------------------
   258         -proc ::dom::domNode::simpleTranslate { node output_var trans_specs } {
   259         -
   260         -    upvar $output_var output
   261         -
   262         -    if {[$node nodeType] == "TEXT_NODE"} {
   263         -        append output [cgiQuote [$node nodeValue]]
   264         -        return
   265         -    }
   266         -    set found 0
   267         -
   268         -    foreach {match action} $trans_specs {
   269         -
   270         -        if {[catch {
   271         -            if {!$found && ([$node selectNode self::$match] != "") } {
   272         -              set found 1
   273         -            }
   274         -        } err]} {
   275         -            if {![string match "NodeSet expected for parent axis!" $err]} {
   276         -                error $err
   277         -            }
   278         -        }
   279         -        if {$found && ($action != "-")} {
   280         -            set stop 0
   281         -            foreach {type value} $action {
   282         -                switch $type {
   283         -                    prefix { append output [subst $value] }
   284         -                    tag    { append output <$value>       }
   285         -                    start  { append output [eval $value]  }
   286         -                    stop   { set stop 1                   }
   287         -                }
   288         -            }
   289         -            if {!$stop} {
   290         -                foreach child [$node childNodes] {
   291         -                    simpleTranslate  $child output $trans_specs
   292         -                }
   293         -            }
   294         -            foreach {type value} $action {
   295         -                switch $type {
   296         -                    suffix { append output [subst $value] }
   297         -                    end    { append output [eval $value]  }
   298         -                    tag    { append output </$value>      }
   299         -                }
   300         -            }
   301         -            return
   302         -        }
   303         -    }
   304         -    foreach child [$node childNodes] {
   305         -        simpleTranslate $child output $trans_specs
   306         -    }
   307         -}
   308         -
   309         -#----------------------------------------------------------------------------
   310         -#   a DOM conformant 'live' childNodes
   311         -#
   312         -#   @return   a 'nodelist' object (it is just the normal node)
   313         -#
   314         -#----------------------------------------------------------------------------
   315         -proc ::dom::domNode::childNodesLive { node } {
   316         -
   317         -    return $node
   318         -}
   319         -
   320         -#----------------------------------------------------------------------------
   321         -#   item method on a 'nodelist' object
   322         -#
   323         -#   @return   a 'nodelist' object (it is just a normal
   324         -#
   325         -#----------------------------------------------------------------------------
   326         -proc ::dom::domNode::item { nodeListNode index } {
   327         -
   328         -    return [lindex [$nodeListNode childNodes] $index]
   329         -}
   330         -
   331         -#----------------------------------------------------------------------------
   332         -#   length method on a 'nodelist' object
   333         -#
   334         -#   @return   a 'nodelist' object (it is just a normal
   335         -#
   336         -#----------------------------------------------------------------------------
   337         -proc ::dom::domNode::length { nodeListNode } {
   338         -
   339         -    return [llength [$nodeListNode childNodes]]
   340         -}
   341         -
   342         -#----------------------------------------------------------------------------
   343         -#   appendData on a 'CharacterData' object
   344         -#
   345         -#----------------------------------------------------------------------------
   346         -proc ::dom::domNode::appendData { node  arg } {
   347         -
   348         -    set type [$node nodeType]
   349         -    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
   350         -        ($type != "COMMENT_NODE")
   351         -    } {
   352         -        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
   353         -    }
   354         -    set oldValue [$node nodeValue]
   355         -    $node nodeValue [append oldValue $arg]
   356         -}
   357         -
   358         -#----------------------------------------------------------------------------
   359         -#   deleteData on a 'CharacterData' object
   360         -#
   361         -#----------------------------------------------------------------------------
   362         -proc ::dom::domNode::deleteData { node offset count } {
   363         -
   364         -    set type [$node nodeType]
   365         -    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
   366         -        ($type != "COMMENT_NODE")
   367         -    } {
   368         -        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
   369         -    }
   370         -    incr offset -1
   371         -    set before [string range [$node nodeValue] 0 $offset]
   372         -    incr offset
   373         -    incr offset $count
   374         -    set after  [string range [$node nodeValue] $offset end]
   375         -    $node nodeValue [append before $after]
   376         -}
   377         -
   378         -#----------------------------------------------------------------------------
   379         -#   insertData on a 'CharacterData' object
   380         -#
   381         -#----------------------------------------------------------------------------
   382         -proc ::dom::domNode::insertData { node  offset arg } {
   383         -
   384         -    set type [$node nodeType]
   385         -    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
   386         -        ($type != "COMMENT_NODE")
   387         -    } {
   388         -        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
   389         -    }
   390         -    incr offset -1
   391         -    set before [string range [$node nodeValue] 0 $offset]
   392         -    incr offset
   393         -    set after  [string range [$node nodeValue] $offset end]
   394         -    $node nodeValue [append before $arg $after]
   395         -}
   396         -
   397         -#----------------------------------------------------------------------------
   398         -#   replaceData on a 'CharacterData' object
   399         -#
   400         -#----------------------------------------------------------------------------
   401         -proc ::dom::domNode::replaceData { node offset count arg } {
   402         -
   403         -    set type [$node nodeType]
   404         -    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
   405         -        ($type != "COMMENT_NODE")
   406         -    } {
   407         -        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
   408         -    }
   409         -    incr offset -1
   410         -    set before [string range [$node nodeValue] 0 $offset]
   411         -    incr offset
   412         -    incr offset $count
   413         -    set after  [string range [$node nodeValue] $offset end]
   414         -    $node nodeValue [append before $arg $after]
   415         -}
   416         -
   417         -#----------------------------------------------------------------------------
   418         -#   substringData on a 'CharacterData' object
   419         -#
   420         -#   @return   part of the node value (text)
   421         -#
   422         -#----------------------------------------------------------------------------
   423         -proc ::dom::domNode::substringData { node offset count } {
   424         -
   425         -    set type [$node nodeType]
   426         -    if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") &&
   427         -        ($type != "COMMENT_NODE")
   428         -    } {
   429         -        return -code error "NOT_SUPPORTED_ERR: node is not a cdata node"
   430         -    }
   431         -    set endOffset [expr $offset + $count - 1]
   432         -    return [string range [$node nodeValue] $offset $endOffset]
   433         -}
   434         -
   435         -#----------------------------------------------------------------------------
   436         -#   coerce2number
   437         -#
   438         -#----------------------------------------------------------------------------
   439         -proc ::dom::xpathFuncHelper::coerce2number { type value } {
   440         -    switch $type {
   441         -        empty      { return 0 }
   442         -        number -
   443         -        string     { return $value }
   444         -        attrvalues { return [lindex $value 0] }
   445         -        nodes      { return [[lindex $value 0] selectNodes number()] }
   446         -        attrnodes  { return [lindex $value 1] }
   447         -    }
   448         -}
   449         -
   450         -#----------------------------------------------------------------------------
   451         -#   coerce2string
   452         -#
   453         -#----------------------------------------------------------------------------
   454         -proc ::dom::xpathFuncHelper::coerce2string { type value } {
   455         -    switch $type {
   456         -        empty      { return "" }
   457         -        number -
   458         -        string     { return $value }
   459         -        attrvalues { return [lindex $value 0] }
   460         -        nodes      { return [[lindex $value 0] selectNodes string()] }
   461         -        attrnodes  { return [lindex $value 1] }
   462         -    }
   463         -}
   464         -
   465         -#----------------------------------------------------------------------------
   466         -#   function-available
   467         -#
   468         -#----------------------------------------------------------------------------
   469         -proc ::dom::xpathFunc::function-available { ctxNode pos
   470         -                                            nodeListType nodeList args} {
   471         -
   472         -    if {[llength $args] != 2} {
   473         -        error "function-available(): wrong # of args!"
   474         -    }
   475         -    foreach { arg1Typ arg1Value } $args break
   476         -    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
   477         -    switch $str {
   478         -        boolean -
   479         -        ceiling -
   480         -        concat -
   481         -        contains -
   482         -        count -
   483         -        current -
   484         -        document -
   485         -        element-available -
   486         -        false -
   487         -        floor -
   488         -        format-number -
   489         -        generate-id -
   490         -        id -
   491         -        key -
   492         -        last -
   493         -        lang -
   494         -        local-name -
   495         -        name -
   496         -        namespace-uri -
   497         -        normalize-space -
   498         -        not -
   499         -        number -
   500         -        position -
   501         -        round -
   502         -        starts-with -
   503         -        string -
   504         -        string-length -
   505         -        substring -
   506         -        substring-after -
   507         -        substring-before -
   508         -        sum -
   509         -        translate -
   510         -        true -
   511         -        unparsed-entity-uri {
   512         -            return [list bool true]
   513         -        }
   514         -        default {
   515         -            set TclXpathFuncs [info procs ::dom::xpathFunc::*]
   516         -            if {[lsearch -exact $TclXpathFuncs $str] != -1} {
   517         -                return [list bool true]
   518         -            } else {
   519         -                return [list bool false]
   520         -            }
   521         -        }
   522         -    }
   523         -}
   524         -
   525         -#----------------------------------------------------------------------------
   526         -#   element-available
   527         -#
   528         -#   This is not strictly correct. The XSLT namespace may be bound
   529         -#   to another prefix (and the prefix 'xsl' may be bound to another
   530         -#   namespace). Since the expression context isn't available at the
   531         -#   moment at tcl coded XPath functions, this couldn't be done better
   532         -#   than this "works in the 'normal' cases" version.
   533         -#----------------------------------------------------------------------------
   534         -proc ::dom::xpathFunc::element-available { ctxNode pos
   535         -                                            nodeListType nodeList args} {
   536         -
   537         -    if {[llength $args] != 2} {
   538         -        error "element-available(): wrong # of args!"
   539         -    }
   540         -    foreach { arg1Typ arg1Value } $args break
   541         -    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
   542         -    # The XSLT recommendation says: "The element-available
   543         -    # function returns true if and only if the expanded-name
   544         -    # is the name of an instruction." The following xsl
   545         -    # elements are not in the category instruction.
   546         -    # xsl:attribute-set 
   547         -    # xsl:decimal-format 
   548         -    # xsl:include
   549         -    # xsl:key 
   550         -    # xsl:namespace-alias
   551         -    # xsl:output
   552         -    # xsl:param
   553         -    # xsl:strip-space
   554         -    # xsl:preserve-space
   555         -    # xsl:template
   556         -    # xsl:import
   557         -    # xsl:otherwise
   558         -    # xsl:sort
   559         -    # xsl:stylesheet
   560         -    # xsl:transform
   561         -    # xsl:with-param
   562         -    # xsl:when
   563         -    switch $str {
   564         -        xsl:apply-templates -
   565         -        xsl:apply-imports -
   566         -        xsl:call-template -
   567         -        xsl:element -
   568         -        xsl:attribute -
   569         -        xsl:text -
   570         -        xsl:processing-instruction -
   571         -        xsl:comment -
   572         -        xsl:copy -
   573         -        xsl:value-of -
   574         -        xsl:number -
   575         -        xsl:for-each -
   576         -        xsl:if -
   577         -        xsl:choose -
   578         -        xsl:variable -
   579         -        xsl:copy-of -
   580         -        xsl:message -
   581         -        xsl:fallback {
   582         -            return [list bool true]
   583         -        }
   584         -        default {
   585         -            return [list bool false]
   586         -        }
   587         -    }
   588         -}
   589         -
   590         -#----------------------------------------------------------------------------
   591         -#   system-property
   592         -#
   593         -#   This is not strictly correct. The XSLT namespace may be bound
   594         -#   to another prefix (and the prefix 'xsl' may be bound to another
   595         -#   namespace). Since the expression context isn't available at the
   596         -#   moment at tcl coded XPath functions, this couldn't be done better
   597         -#   than this "works in the 'normal' cases" version.
   598         -#----------------------------------------------------------------------------
   599         -proc ::dom::xpathFunc::system-property { ctxNode pos
   600         -                                         nodeListType nodeList args } {
   601         -
   602         -    if {[llength $args] != 2} {
   603         -        error "system-property(): wrong # of args!"
   604         -    }
   605         -    foreach { arg1Typ arg1Value } $args break
   606         -    set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ]
   607         -    switch $str {
   608         -        xsl:version {
   609         -            return [list number 1.0]
   610         -        }
   611         -        xsl:vendor {
   612         -            return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."]
   613         -        }
   614         -        xsl:vendor-url {
   615         -            return [list string "http://www.tdom.org"]
   616         -        }
   617         -        default {
   618         -            return [list string ""]
   619         -        }
   620         -    }
   621         -}
   622         -
   623         -#----------------------------------------------------------------------------
   624         -#   IANAEncoding2TclEncoding
   625         -#
   626         -#----------------------------------------------------------------------------
   627         -
   628         -# As of version 8.3.4 tcl supports 
   629         -# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949
   630         -# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201
   631         -# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp
   632         -# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737
   633         -# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr
   634         -# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic
   635         -# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6
   636         -# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253
   637         -# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852
   638         -# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode
   639         -# cp857
   640         -# 
   641         -# Just add more mappings (and mail them to the tDOM mailing list, please).
   642         -
   643         -proc tDOM::IANAEncoding2TclEncoding {IANAName} {
   644         -    
   645         -    # First the most widespread encodings with there
   646         -    # preferred MIME name, to speed lookup in this
   647         -    # usual cases. Later the official names and the
   648         -    # aliases.
   649         -    #
   650         -    # For "official names for character sets that may be
   651         -    # used in the Internet" see 
   652         -    # http://www.iana.org/assignments/character-sets
   653         -    # (that's the source for the encoding names below)
   654         -    # 
   655         -    # Matching is case-insensitive
   656         -
   657         -    switch [string tolower $IANAName] {
   658         -        "us-ascii"    {return ascii}
   659         -        "utf-8"       {return utf-8}
   660         -        "utf-16"      {return unicode; # not sure about this}
   661         -        "iso-8859-1"  {return iso8859-1}
   662         -        "iso-8859-2"  {return iso8859-2}
   663         -        "iso-8859-3"  {return iso8859-3}
   664         -        "iso-8859-4"  {return iso8859-4}
   665         -        "iso-8859-5"  {return iso8859-5}
   666         -        "iso-8859-6"  {return iso8859-6}
   667         -        "iso-8859-7"  {return iso8859-7}
   668         -        "iso-8859-8"  {return iso8859-8}
   669         -        "iso-8859-9"  {return iso8859-9}
   670         -        "iso-8859-10" {return iso8859-10}
   671         -        "iso-8859-13" {return iso8859-13}
   672         -        "iso-8859-14" {return iso8859-14}
   673         -        "iso-8859-15" {return iso8859-15}
   674         -        "iso-8859-16" {return iso8859-16}
   675         -        "iso-2022-kr" {return iso2022-kr}
   676         -        "euc-kr"      {return euc-kr}
   677         -        "iso-2022-jp" {return iso2022-jp}
   678         -        "koi8-r"      {return koi8-r}
   679         -        "shift_jis"   {return shiftjis}
   680         -        "euc-jp"      {return euc-jp}
   681         -        "gb2312"      {return gb2312}
   682         -        "big5"        {return big5}
   683         -        "cp866"       {return cp866}
   684         -        "cp1250"      {return cp1250}
   685         -        "cp1253"      {return cp1253}
   686         -        "cp1254"      {return cp1254}
   687         -        "cp1255"      {return cp1255}
   688         -        "cp1256"      {return cp1256}
   689         -        "cp1257"      {return cp1257}
   690         -
   691         -        "windows-1251" -
   692         -        "cp1251"      {return cp1251}
   693         -
   694         -        "windows-1252" -
   695         -        "cp1252"      {return cp1252}    
   696         -
   697         -        "iso_8859-1:1987" -
   698         -        "iso-ir-100" -
   699         -        "iso_8859-1" -
   700         -        "latin1" -
   701         -        "l1" -
   702         -        "ibm819" -
   703         -        "cp819" -
   704         -        "csisolatin1" {return iso8859-1}
   705         -        
   706         -        "iso_8859-2:1987" -
   707         -        "iso-ir-101" -
   708         -        "iso_8859-2" -
   709         -        "iso-8859-2" -
   710         -        "latin2" -
   711         -        "l2" -
   712         -        "csisolatin2" {return iso8859-2}
   713         -
   714         -        "iso_8859-5:1988" -
   715         -        "iso-ir-144" -
   716         -        "iso_8859-5" -
   717         -        "iso-8859-5" -
   718         -        "cyrillic" -
   719         -        "csisolatincyrillic" {return iso8859-5}
   720         -
   721         -        "ms_kanji" -
   722         -        "csshiftjis"  {return shiftjis}
   723         -        
   724         -        "csiso2022kr" {return iso2022-kr}
   725         -
   726         -        "ibm866" -
   727         -        "csibm866"    {return cp866}
   728         -        
   729         -        default {
   730         -            # There are much more encoding names out there
   731         -            # It's only laziness, that let me stop here.
   732         -            error "Unrecognized encoding name '$IANAName'"
   733         -        }
   734         -    }
   735         -}
   736         -
   737         -#----------------------------------------------------------------------------
   738         -#   xmlOpenFile
   739         -#
   740         -#----------------------------------------------------------------------------
   741         -proc tDOM::xmlOpenFile {filename {encodingString {}}} {
   742         -
   743         -    set fd [open $filename]
   744         -
   745         -    if {$encodingString != {}} {
   746         -        upvar $encodingString encString
   747         -    }
   748         -
   749         -    # The autodetection of the encoding follows
   750         -    # XML Recomendation, Appendix F
   751         -
   752         -    fconfigure $fd -encoding binary
   753         -    if {![binary scan [read $fd 4] "H8" firstBytes]} {
   754         -        # very short (< 4 Bytes) file
   755         -        seek $fd 0 start
   756         -        set encString UTF-8
   757         -        return $fd
   758         -    }
   759         -    
   760         -    # First check for BOM
   761         -    switch [string range $firstBytes 0 3] {
   762         -        "feff" -
   763         -        "fffe" {
   764         -            # feff: UTF-16, big-endian BOM
   765         -            # ffef: UTF-16, little-endian BOM
   766         -            seek $fd 0 start
   767         -            set encString UTF-16            
   768         -            fconfigure $fd -encoding identity
   769         -            return $fd
   770         -        }
   771         -    }
   772         -
   773         -    # If the entity has a XML Declaration, the first four characters
   774         -    # must be "<?xm".
   775         -    switch $firstBytes {
   776         -        "3c3f786d" {
   777         -            # UTF-8, ISO 646, ASCII, some part of ISO 8859, Shift-JIS,
   778         -            # EUC, or any other 7-bit, 8-bit, or mixed-width encoding which 
   779         -            # ensures that the characters of ASCII have their normal positions,
   780         -            # width and values; the actual encoding declaration must be read to
   781         -            # detect which of these applies, but since all of these encodings
   782         -            # use the same bit patterns for the ASCII characters, the encoding
   783         -            # declaration itself be read reliably.
   784         -
   785         -            # First 300 bytes should be enough for a XML Declaration
   786         -            # This is of course not 100 percent bullet-proof.
   787         -            set head [read $fd 296]
   788         -
   789         -            # Try to find the end of the XML Declaration
   790         -            set closeIndex [string first ">" $head]
   791         -            if {$closeIndex == -1} {
   792         -                error "Weird XML data or not XML data at all"
   793         -            }
   794         -
   795         -            seek $fd 0 start
   796         -            set xmlDeclaration [read $fd [expr {$closeIndex + 5}]]
   797         -            # extract the encoding information
   798         -            set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]}
   799         -            # emacs: "
   800         -            if {![regexp $pattern $head - encStr]} {
   801         -                # Probably something like <?xml version="1.0"?>. 
   802         -                # Without encoding declaration this must be UTF-8
   803         -                set encoding utf-8
   804         -                set encString UTF-8
   805         -            } else {
   806         -                set encoding [IANAEncoding2TclEncoding $encStr]
   807         -                set encString $encStr
   808         -            }
   809         -        }
   810         -        "0000003c" -
   811         -        "0000003c" -
   812         -        "3c000000" -
   813         -        "00003c00" {
   814         -            # UCS-4
   815         -            error "UCS-4 not supported"
   816         -        }
   817         -        "003c003f" -
   818         -        "3c003f00" {
   819         -            # UTF-16, big-endian, no BOM
   820         -            # UTF-16, little-endian, no BOM
   821         -            seek $fd 0 start
   822         -            set encoding identity
   823         -            set encString UTF-16
   824         -        }
   825         -        "4c6fa794" {
   826         -            # EBCDIC in some flavor
   827         -            error "EBCDIC not supported"
   828         -        }
   829         -        default {
   830         -            # UTF-8 without an encoding declaration
   831         -            seek $fd 0 start
   832         -            set encoding identity
   833         -            set encString "UTF-8"
   834         -        }
   835         -    }
   836         -    fconfigure $fd -encoding $encoding
   837         -    return $fd
   838         -}
   839         -
   840         -#----------------------------------------------------------------------------
   841         -#   xmlReadFile
   842         -#
   843         -#----------------------------------------------------------------------------
   844         -proc tDOM::xmlReadFile {filename {encodingString {}}} {
   845         -
   846         -    if {$encodingString != {}} {
   847         -        upvar $encodingString encString
   848         -    }
   849         -    
   850         -    set fd [xmlOpenFile $filename encString]
   851         -    set data [read $fd [file size $filename]]
   852         -    close $fd 
   853         -    return $data
   854         -}
   855         -
   856         -#----------------------------------------------------------------------------
   857         -#   extRefHandler
   858         -#   
   859         -#   A very simple external entity resolver, included for convenience.
   860         -#   Depends on the tcllib package uri and resolves only file URLs. 
   861         -#
   862         -#----------------------------------------------------------------------------
   863         -
   864         -if {![catch {package require uri}]} {
   865         -    proc tDOM::extRefHandler {base systemId publicId} {
   866         -        variable extRefHandlerDebug
   867         -        variable useForeignDTD
   868         -
   869         -        if {$extRefHandlerDebug} {
   870         -            puts stderr "tDOM::extRefHandler called with:"
   871         -            puts stderr "\tbase:     '$base'"
   872         -            puts stderr "\tsystemId: '$systemId'"
   873         -            puts stderr "\tpublicId: '$publicId'"
   874         -        }
   875         -        if {$systemId == ""} {
   876         -            if {$useForeignDTD != ""} {
   877         -                set systemId $useForeignDTD
   878         -            } else {
   879         -                error "::tDOM::useForeignDTD does\
   880         -                        not point to the foreign DTD"
   881         -            }
   882         -        }
   883         -        set absolutURI [uri::resolve $base $systemId]
   884         -        array set uriData [uri::split $absolutURI]
   885         -        switch $uriData(scheme) {
   886         -            file {
   887         -                return [list string $absolutURI [xmlReadFile $uriData(path)]]
   888         -            }
   889         -            default {
   890         -                error "can only handle file URI's"
   891         -            }
   892         -        }
   893         -    }
   894         -}
   895         -
   896         -#----------------------------------------------------------------------------
   897         -#   baseURL
   898         -#   
   899         -#   A simple convenience proc which returns an absolute URL for a given
   900         -#   filename.
   901         -#
   902         -#----------------------------------------------------------------------------
   903         -
   904         -proc tDOM::baseURL {path} {
   905         -    switch [file pathtype $path] {
   906         -        "relative" {
   907         -            return "file://[pwd]/$path"
   908         -        }
   909         -        default {
   910         -            return "file://$path"
   911         -        }
   912         -    }
   913         -}
   914         -
   915         -# EOF

Deleted winlibs/tdom/tdom083.dll.

cannot compute difference between binary files

Deleted winlibs/twapi/LICENSE.

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

Deleted winlibs/twapi/README.TXT.

     1         -# Tcl Windows API (TWAPI) 4.1
     2         -
     3         -This is the release version of TWAPI 4.1.
     4         -
     5         -  * Project home page is at http://twapi.sourceforge.net
     6         -  * V4.1 documentation is at http://twapi.sourceforge.net/v4.1
     7         -
     8         -## Supported platforms
     9         -
    10         -TWAPI 4.1 requires
    11         -
    12         -  * Windows XP (32-bit only) or later (32- or 64- bit)
    13         -  * Tcl 8.5 or 8.6 (32- or 64-bit)
    14         -
    15         -## Changes since 4.0
    16         -
    17         -Major changes in this release are support for writing COM servers
    18         -and other COM enhancements, STARTTLS support for TLS sockets,
    19         -and additional functionality in the security, services,
    20         -device management and console modules.
    21         -
    22         -For a complete list, including INCOMPATIBLE CHANGES, see 
    23         -http://twapi.sourceforge.net/v4.1/versionhistory.html
    24         -
    25         -## Distributions
    26         -
    27         -TWAPI is distributed in multiple formats.
    28         -See http://twapi.sourceforge.net/v4.1/installation.html for the details
    29         -and the pros and cons of each format.
    30         -
    31         -## TWAPI Summary
    32         -
    33         -The Tcl Windows API (TWAPI) extension provides
    34         -access to over 600 functions in the Windows API
    35         -from within the Tcl scripting language.
    36         -
    37         -Functions in the following areas are implemented:
    38         -
    39         -  * System functions including OS and CPU information,
    40         -    shutdown and message formatting
    41         -  * User and group management
    42         -  * COM client and server support
    43         -  * Security and resource access control
    44         -  * Window management
    45         -  * User input: generate key/mouse input and hotkeys
    46         -  * Basic sound playback functions
    47         -  * Windows services
    48         -  * Windows event log access
    49         -  * Windows event tracing
    50         -  * Process and thread management
    51         -  * Directory change monitoring
    52         -  * Lan Manager and file and print shares
    53         -  * Drive information, file system types etc.
    54         -  * Network configuration and statistics
    55         -  * Network connection monitoring and control
    56         -  * Named pipes
    57         -  * Clipboard access
    58         -  * Taskbar icons and notifications
    59         -  * Console mode functions
    60         -  * Window stations and desktops
    61         -  * Internationalization
    62         -  * Task scheduling
    63         -  * Shell functions 
    64         -  * Windows Installer
    65         -  * Synchronization
    66         -  * Power management
    67         -  * Device I/O and management
    68         -  * Crypto API and certificates
    69         -  * SSL/TLS
    70         -  * Windows Performance Counters

Deleted winlibs/twapi/accounts.tcl.

     1         -#
     2         -# Copyright (c) 2009-2015, Ashok P. Nadkarni
     3         -# All rights reserved.
     4         -#
     5         -# See the file LICENSE for license
     6         -
     7         -package require twapi_security
     8         -
     9         -namespace eval twapi {
    10         -    record USER_INFO_0 {-name}
    11         -    record USER_INFO_1 [concat [USER_INFO_0] {
    12         -        -password -password_age -priv -home_dir -comment -flags -script_path
    13         -    }]
    14         -    record USER_INFO_2 [concat [USER_INFO_1] {
    15         -        -auth_flags -full_name -usr_comment -parms 
    16         -        -workstations -last_logon -last_logoff -acct_expires -max_storage
    17         -        -units_per_week -logon_hours -bad_pw_count -num_logons
    18         -        -logon_server -country_code -code_page
    19         -    }]
    20         -    record USER_INFO_3 [concat [USER_INFO_2] {
    21         -        -user_id -primary_group_id -profile -home_dir_drive -password_expired
    22         -    }]
    23         -    record USER_INFO_4 [concat [USER_INFO_2] {
    24         -        -sid -primary_group_id -profile -home_dir_drive -password_expired
    25         -    }]
    26         -
    27         -    record GROUP_INFO_0 {-name}
    28         -    record GROUP_INFO_1 {-name -comment}
    29         -    record GROUP_INFO_2 {-name -comment -group_id -attributes}
    30         -    record GROUP_INFO_3 {-name -comment -sid -attributes}
    31         -
    32         -    record NetEnumResult {moredata hresume totalentries entries}
    33         -
    34         -}
    35         -
    36         -# Add a new user account
    37         -proc twapi::new_user {username args} {
    38         -    array set opts [parseargs args [list \
    39         -                                        system.arg \
    40         -                                        password.arg \
    41         -                                        comment.arg \
    42         -                                        [list priv.arg "user" [array names twapi::priv_level_map]] \
    43         -                                        home_dir.arg \
    44         -                                        script_path.arg \
    45         -                                       ] \
    46         -                        -nulldefault]
    47         -
    48         -    if {$opts(priv) ne "user"} {
    49         -        error "Option -priv is deprecated and values other than 'user' are not allowed"
    50         -    }
    51         -
    52         -    # 1 -> priv level 'user'. NetUserAdd mandates this as only allowed value
    53         -    NetUserAdd $opts(system) $username $opts(password) 1 \
    54         -        $opts(home_dir) $opts(comment) 0 $opts(script_path)
    55         -
    56         -
    57         -    # Backward compatibility - add to 'Users' local group
    58         -    # but only if -system is local
    59         -    if {$opts(system) eq "" ||
    60         -        ([info exists ::env(COMPUTERNAME)] &&
    61         -         [string equal -nocase $opts(system) $::env(COMPUTERNAME)])} {
    62         -        trap {
    63         -            _set_user_priv_level $username $opts(priv) -system $opts(system)
    64         -        } onerror {} {
    65         -            # Remove the previously created user account
    66         -            catch {delete_user $username -system $opts(system)}
    67         -            rethrow
    68         -        }
    69         -    }
    70         -}
    71         -
    72         -
    73         -# Delete a user account
    74         -proc twapi::delete_user {username args} {
    75         -    array set opts [parseargs args {system.arg} -nulldefault]
    76         -
    77         -    # Remove the user from the LSA rights database.
    78         -    _delete_rights $username $opts(system)
    79         -
    80         -    NetUserDel $opts(system) $username
    81         -}
    82         -
    83         -
    84         -# Define various functions to set various user account fields
    85         -foreach twapi::_field_ {
    86         -    {name  0}
    87         -    {password  1003}
    88         -    {home_dir  1006}
    89         -    {comment  1007}
    90         -    {script_path  1009}
    91         -    {full_name  1011}
    92         -    {country_code  1024}
    93         -    {profile  1052}
    94         -    {home_dir_drive  1053}
    95         -} {
    96         -    proc twapi::set_user_[lindex $::twapi::_field_ 0] {username fieldval args} "
    97         -        array set opts \[parseargs args {
    98         -            system.arg
    99         -        } -nulldefault \]
   100         -        Twapi_NetUserSetInfo [lindex $::twapi::_field_ 1] \$opts(system) \$username \$fieldval"
   101         -}
   102         -unset twapi::_field_
   103         -
   104         -# Set account expiry time
   105         -proc twapi::set_user_expiration {username time args} {
   106         -    array set opts [parseargs args {system.arg} -nulldefault]
   107         -
   108         -    if {![string is integer -strict $time]} {
   109         -        if {[string equal $time "never"]} {
   110         -            set time -1
   111         -        } else {
   112         -            set time [clock scan $time]
   113         -        }
   114         -    }
   115         -    Twapi_NetUserSetInfo 1017 $opts(system) $username $time
   116         -}
   117         -
   118         -# Unlock a user account
   119         -proc twapi::unlock_user {username args} {
   120         -    # UF_LOCKOUT -> 0x10
   121         -    _change_user_info_flags $username 0x10 0 {*}$args
   122         -}
   123         -
   124         -# Enable a user account
   125         -proc twapi::enable_user {username args} {
   126         -    # UF_ACCOUNTDISABLE -> 0x2
   127         -    _change_user_info_flags $username 0x2 0 {*}$args
   128         -}
   129         -
   130         -# Disable a user account
   131         -proc twapi::disable_user {username args} {
   132         -    # UF_ACCOUNTDISABLE -> 0x2
   133         -    _change_user_info_flags $username 0x2 0x2 {*}$args
   134         -}
   135         -
   136         -
   137         -# Return the specified fields for a user account
   138         -proc twapi::get_user_account_info {account args} {
   139         -    # Define each option, the corresponding field, and the 
   140         -    # information level at which it is returned
   141         -    array set fields {
   142         -        comment 1
   143         -        password_expired 4
   144         -        full_name 2
   145         -        parms 2
   146         -        units_per_week 2
   147         -        primary_group_id 4
   148         -        flags 1
   149         -        logon_server 2
   150         -        country_code 2
   151         -        home_dir 1
   152         -        password_age 1
   153         -        home_dir_drive 4
   154         -        num_logons 2
   155         -        acct_expires 2
   156         -        last_logon 2
   157         -        usr_comment 2
   158         -        bad_pw_count 2
   159         -        code_page 2
   160         -        logon_hours 2
   161         -        workstations 2
   162         -        last_logoff 2
   163         -        name 0
   164         -        script_path 1
   165         -        profile 4
   166         -        max_storage 2
   167         -    }
   168         -    # Left out - auth_flags 2
   169         -    # Left out (always returned as NULL) - password {usri3_password 1}
   170         -    # Note sid is available at level 4 as well but don't want to set
   171         -    # level 4 just for that since we can get it by other means. Hence
   172         -    # not listed above
   173         -
   174         -    array set opts [parseargs args \
   175         -                        [concat [array names fields] sid \
   176         -                             internet_identity \
   177         -                             status type password_attrs \
   178         -                             [list local_groups global_groups system.arg all]] \
   179         -                        -nulldefault]
   180         -
   181         -    if {$opts(all)} {
   182         -        set level 4
   183         -        set opts(local_groups) 1
   184         -        set opts(global_groups) 1
   185         -    } else {
   186         -        # Based on specified fields, figure out what level info to ask for
   187         -        set level -1
   188         -        foreach {opt optval} [array get opts] {
   189         -            if {[info exists fields($opt)] &&
   190         -                $optval &&
   191         -                $fields($opt) > $level
   192         -            } {
   193         -                set level $fields($opt)
   194         -            }
   195         -        }                
   196         -        if {$opts(status) || $opts(type) || $opts(password_attrs)} {
   197         -            # These fields are based on the flags field
   198         -            if {$level < 1} {
   199         -                set level 1
   200         -            }
   201         -        }
   202         -    }
   203         -    
   204         -    array set result [list ]
   205         -
   206         -    if {$level > -1} {
   207         -        set rawdata [NetUserGetInfo $opts(system) $account $level]
   208         -        array set data [USER_INFO_$level $rawdata]
   209         -
   210         -        # Extract the requested data
   211         -        foreach opt [array names fields] {
   212         -            if {$opts(all) || $opts($opt)} {
   213         -                set result(-$opt) $data(-$opt)
   214         -            }
   215         -        }
   216         -        if {$level == 4 && ($opts(all) || $opts(sid))} {
   217         -            set result(-sid) $data(-sid)
   218         -        }
   219         -
   220         -        # Map internal values to more friendly formats
   221         -        if {$opts(all) || $opts(status) || $opts(type) || $opts(password_attrs)} {
   222         -            array set result [_map_userinfo_flags $data(-flags)]
   223         -            if {! $opts(all)} {
   224         -                if {! $opts(status)} {unset result(-status)}
   225         -                if {! $opts(type)} {unset result(-type)}
   226         -                if {! $opts(password_attrs)} {unset result(-password_attrs)}
   227         -            }
   228         -        }
   229         -
   230         -        if {[info exists result(-logon_hours)]} {
   231         -            binary scan $result(-logon_hours) b* result(-logon_hours)
   232         -        }
   233         -
   234         -        foreach time_field {-acct_expires -last_logon -last_logoff} {
   235         -            if {[info exists result($time_field)]} {
   236         -                if {$result($time_field) == -1 || $result($time_field) == 4294967295} {
   237         -                    set result($time_field) "never"
   238         -                } elseif {$result($time_field) == 0} {
   239         -                    set result($time_field) "unknown"
   240         -                }
   241         -            }
   242         -        }
   243         -    }
   244         -
   245         -    if {$opts(all) || $opts(internet_identity)} {
   246         -        set result(-internet_identity) {}
   247         -        if {[min_os_version 6 2]} {
   248         -            set inet_ident [NetUserGetInfo $opts(system) $account 24]
   249         -            if {[llength $inet_ident]} {
   250         -                set result(-internet_identity) [twine {
   251         -                    internet_provider_name internet_principal_name sid
   252         -                } [lrange $inet_ident 1 end]]
   253         -            }
   254         -        }
   255         -    }
   256         -
   257         -    # The Net* calls always return structures as lists even when the struct
   258         -    # contains only one field so we need to lpick to extract the field
   259         -
   260         -    if {$opts(local_groups)} {
   261         -        set result(-local_groups) [lpick [NetEnumResult entries [NetUserGetLocalGroups $opts(system) $account 0 0]] 0]
   262         -    }
   263         -
   264         -    if {$opts(global_groups)} {
   265         -        set result(-global_groups) [lpick [NetEnumResult entries [NetUserGetGroups $opts(system) $account 0]] 0]
   266         -    }
   267         -
   268         -    if {$opts(sid)  && ! [info exists result(-sid)]} {
   269         -        set result(-sid) [lookup_account_name $account -system $opts(system)]
   270         -    }
   271         -
   272         -    return [array get result]
   273         -}
   274         -
   275         -proc twapi::get_user_global_groups {account args} {
   276         -    parseargs args {
   277         -        system.arg
   278         -        denyonly
   279         -        all
   280         -    } -nulldefault -maxleftover 0 -setvars
   281         -
   282         -    set groups {}
   283         -    foreach elem [NetEnumResult entries [NetUserGetGroups $system [map_account_to_name $account -system $system] 1]] {
   284         -        # 0x10 -> SE_GROUP_USE_FOR_DENY_ONLY
   285         -        set marked_denyonly [expr {[lindex $elem 1] & 0x10}]
   286         -        if {$all || ($denyonly && $marked_denyonly) || !($denyonly || $marked_denyonly)} {
   287         -            lappend groups [lindex $elem 0]
   288         -        }
   289         -    }
   290         -    return $groups
   291         -}
   292         -
   293         -proc twapi::get_user_local_groups {account args} {
   294         -    parseargs args {
   295         -        system.arg
   296         -        {recurse.bool 0}
   297         -    } -nulldefault -maxleftover 0 -setvars
   298         -
   299         -    # The Net* calls always return structures as lists even when the struct
   300         -    # contains only one field so we need to lpick to extract the field
   301         -    return [lpick [NetEnumResult entries [NetUserGetLocalGroups $system [map_account_to_name $account -system $system] 0 $recurse]] 0]
   302         -}
   303         -
   304         -proc twapi::get_user_local_groups_recursive {account args} {
   305         -    return [get_user_local_groups $account {*}$args -recurse 1]
   306         -}
   307         -
   308         -
   309         -# Set the specified fields for a user account
   310         -proc twapi::set_user_account_info {account args} {
   311         -
   312         -    # Define each option, the corresponding field, and the 
   313         -    # information level at which it is returned
   314         -    array set opts [parseargs args {
   315         -        {system.arg ""}
   316         -        comment.arg
   317         -        full_name.arg
   318         -        country_code.arg
   319         -        home_dir.arg
   320         -        home_dir.arg
   321         -        acct_expires.arg
   322         -        name.arg
   323         -        script_path.arg
   324         -        profile.arg
   325         -    }]
   326         -
   327         -    # TBD - rewrite this to be atomic
   328         -
   329         -    if {[info exists opts(comment)]} {
   330         -        set_user_comment $account $opts(comment) -system $opts(system)
   331         -    }
   332         -
   333         -    if {[info exists opts(full_name)]} {
   334         -        set_user_full_name $account $opts(full_name) -system $opts(system)
   335         -    }
   336         -
   337         -    if {[info exists opts(country_code)]} {
   338         -        set_user_country_code $account $opts(country_code) -system $opts(system)
   339         -    }
   340         -
   341         -    if {[info exists opts(home_dir)]} {
   342         -        set_user_home_dir $account $opts(home_dir) -system $opts(system)
   343         -    }
   344         -
   345         -    if {[info exists opts(home_dir_drive)]} {
   346         -        set_user_home_dir_drive $account $opts(home_dir_drive) -system $opts(system)
   347         -    }
   348         -
   349         -    if {[info exists opts(acct_expires)]} {
   350         -        set_user_expiration $account $opts(acct_expires) -system $opts(system)
   351         -    }
   352         -
   353         -    if {[info exists opts(name)]} {
   354         -        set_user_name $account $opts(name) -system $opts(system)
   355         -    }
   356         -
   357         -    if {[info exists opts(script_path)]} {
   358         -        set_user_script_path $account $opts(script_path) -system $opts(system)
   359         -    }
   360         -
   361         -    if {[info exists opts(profile)]} {
   362         -        set_user_profile $account $opts(profile) -system $opts(system)
   363         -    }
   364         -}
   365         -                    
   366         -
   367         -proc twapi::get_global_group_info {grpname args} {
   368         -    array set opts [parseargs args {
   369         -        {system.arg ""}
   370         -        comment
   371         -        name
   372         -        members
   373         -        sid
   374         -        attributes
   375         -        all
   376         -    } -maxleftover 0]
   377         -
   378         -    set result {}
   379         -    if {[expr {$opts(comment) || $opts(name) || $opts(sid) || $opts(attributes) || $opts(all)}]} {
   380         -        # 3 -> GROUP_INFO level 3
   381         -        lassign [NetGroupGetInfo $opts(system) $grpname 3] name comment sid attributes
   382         -        if {$opts(all) || $opts(sid)} {
   383         -            lappend result -sid $sid
   384         -        }
   385         -        if {$opts(all) || $opts(name)} {
   386         -            lappend result -name $name
   387         -        }
   388         -        if {$opts(all) || $opts(comment)} {
   389         -            lappend result -comment $comment
   390         -        }
   391         -        if {$opts(all) || $opts(attributes)} {
   392         -            lappend result -attributes [map_token_group_attr $attributes]
   393         -        }
   394         -    }
   395         -
   396         -    if {$opts(all) || $opts(members)} {
   397         -        lappend result -members [get_global_group_members $grpname -system $opts(system)]
   398         -    }
   399         -
   400         -    return $result
   401         -}
   402         -
   403         -# Get info about a local or global group
   404         -proc twapi::get_local_group_info {name args} {
   405         -    array set opts [parseargs args {
   406         -        {system.arg ""}
   407         -        comment
   408         -        name
   409         -        members
   410         -        sid
   411         -        all
   412         -    } -maxleftover 0]
   413         -
   414         -    set result [list ]
   415         -    if {$opts(all) || $opts(sid)} {
   416         -        lappend result -sid [lookup_account_name $name -system $opts(system)]
   417         -    }
   418         -    if {$opts(all) || $opts(comment) || $opts(name)} {
   419         -        lassign [NetLocalGroupGetInfo $opts(system) $name 1] name comment
   420         -        if {$opts(all) || $opts(name)} {
   421         -            lappend result -name $name
   422         -        }
   423         -        if {$opts(all) || $opts(comment)} {
   424         -            lappend result -comment $comment
   425         -        }
   426         -    }
   427         -    if {$opts(all) || $opts(members)} {
   428         -        lappend result -members [get_local_group_members $name -system $opts(system)]
   429         -    }
   430         -    return $result
   431         -}
   432         -
   433         -# Get list of users on a system
   434         -proc twapi::get_users {args} {
   435         -    parseargs args {
   436         -        level.int
   437         -    } -setvars -ignoreunknown
   438         -
   439         -    # TBD -allow user to specify filter
   440         -    lappend args -filter 0
   441         -    if {[info exists level]} {
   442         -        lappend args -level $level -fields [USER_INFO_$level]
   443         -    }
   444         -    return [_net_enum_helper NetUserEnum $args]
   445         -}
   446         -
   447         -proc twapi::get_global_groups {args} {
   448         -    parseargs args {
   449         -        level.int
   450         -    } -setvars -ignoreunknown
   451         -
   452         -    # TBD - level 3 returns an ERROR_INVALID_LEVEL even though
   453         -    # MSDN says its valid for NetGroupEnum
   454         -
   455         -    if {[info exists level]} {
   456         -        lappend args -level $level -fields [GROUP_INFO_$level]
   457         -    }
   458         -    return [_net_enum_helper NetGroupEnum $args]
   459         -}
   460         -
   461         -proc twapi::get_local_groups {args} {
   462         -    parseargs args {
   463         -        level.int
   464         -    } -setvars -ignoreunknown
   465         -
   466         -    if {[info exists level]} {
   467         -        lappend args -level $level -fields [dict get {0 {-name} 1 {-name -comment}} $level]
   468         -    }
   469         -    return [_net_enum_helper NetLocalGroupEnum $args]
   470         -}
   471         -
   472         -# Create a new global group
   473         -proc twapi::new_global_group {grpname args} {
   474         -    array set opts [parseargs args {
   475         -        system.arg
   476         -        comment.arg
   477         -    } -nulldefault]
   478         -
   479         -    NetGroupAdd $opts(system) $grpname $opts(comment)
   480         -}
   481         -
   482         -# Create a new local group
   483         -proc twapi::new_local_group {grpname args} {
   484         -    array set opts [parseargs args {
   485         -        system.arg
   486         -        comment.arg
   487         -    } -nulldefault]
   488         -
   489         -    NetLocalGroupAdd $opts(system) $grpname $opts(comment)
   490         -}
   491         -
   492         -
   493         -# Delete a global group
   494         -proc twapi::delete_global_group {grpname args} {
   495         -    array set opts [parseargs args {system.arg} -nulldefault]
   496         -
   497         -    # Remove the group from the LSA rights database.
   498         -    _delete_rights $grpname $opts(system)
   499         -
   500         -    NetGroupDel $opts(system) $grpname
   501         -}
   502         -
   503         -# Delete a local group
   504         -proc twapi::delete_local_group {grpname args} {
   505         -    array set opts [parseargs args {system.arg} -nulldefault]
   506         -
   507         -    # Remove the group from the LSA rights database.
   508         -    _delete_rights $grpname $opts(system)
   509         -
   510         -    NetLocalGroupDel $opts(system) $grpname
   511         -}
   512         -
   513         -
   514         -# Enumerate members of a global group
   515         -proc twapi::get_global_group_members {grpname args} {
   516         -    parseargs args {
   517         -        level.int
   518         -    } -setvars -ignoreunknown
   519         -
   520         -    if {[info exists level]} {
   521         -        lappend args -level $level -fields [dict! {0 {-name} 1 {-name -attributes}} $level]
   522         -    }
   523         -
   524         -    lappend args -preargs [list $grpname] -namelevel 1
   525         -    return [_net_enum_helper NetGroupGetUsers $args]
   526         -}
   527         -
   528         -# Enumerate members of a local group
   529         -proc twapi::get_local_group_members {grpname args} {
   530         -    parseargs args {
   531         -        level.int
   532         -    } -setvars -ignoreunknown
   533         -
   534         -    if {[info exists level]} {
   535         -        lappend args -level $level -fields [dict! {0 {-sid} 1 {-sid -sidusage -name} 2 {-sid -sidusage -domainandname} 3 {-domainandname}} $level]
   536         -    }
   537         -
   538         -    lappend args -preargs [list $grpname] -namelevel 1 -namefield 2
   539         -    return [_net_enum_helper NetLocalGroupGetMembers $args]
   540         -}
   541         -
   542         -# Add a user to a global group
   543         -proc twapi::add_user_to_global_group {grpname username args} {
   544         -    array set opts [parseargs args {system.arg} -nulldefault]
   545         -
   546         -    # No error if already member of the group
   547         -    trap {
   548         -        NetGroupAddUser $opts(system) $grpname $username
   549         -    } onerror {TWAPI_WIN32 1320} {
   550         -        # Ignore
   551         -    }
   552         -}
   553         -
   554         -
   555         -# Remove a user from a global group
   556         -proc twapi::remove_user_from_global_group {grpname username args} {
   557         -    array set opts [parseargs args {system.arg} -nulldefault]
   558         -
   559         -    trap {
   560         -        NetGroupDelUser $opts(system) $grpname $username
   561         -    } onerror {TWAPI_WIN32 1321} {
   562         -        # Was not in group - ignore
   563         -    }
   564         -}
   565         -
   566         -
   567         -# Add a user to a local group
   568         -proc twapi::add_member_to_local_group {grpname username args} {
   569         -    array set opts [parseargs args {
   570         -        system.arg
   571         -        {type.arg name}
   572         -    } -nulldefault]
   573         -
   574         -    # No error if already member of the group
   575         -    trap {
   576         -        Twapi_NetLocalGroupMembers 0 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] [list $username]
   577         -    } onerror {TWAPI_WIN32 1378} {
   578         -        # Ignore
   579         -    }
   580         -}
   581         -
   582         -proc twapi::add_members_to_local_group {grpname accts args} {
   583         -    array set opts [parseargs args {
   584         -        system.arg
   585         -        {type.arg name}
   586         -    } -nulldefault]
   587         -
   588         -    Twapi_NetLocalGroupMembers 0 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] $accts
   589         -}
   590         -
   591         -
   592         -# Remove a user from a local group
   593         -proc twapi::remove_member_from_local_group {grpname username args} {
   594         -    array set opts [parseargs args {
   595         -        system.arg
   596         -        {type.arg name}
   597         -    } -nulldefault]
   598         -
   599         -    trap {
   600         -        Twapi_NetLocalGroupMembers 1 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] [list $username]
   601         -    } onerror {TWAPI_WIN32 1377} {
   602         -        # Was not in group - ignore
   603         -    }
   604         -}
   605         -
   606         -proc twapi::remove_members_from_local_group {grpname accts args} {
   607         -    array set opts [parseargs args {
   608         -        system.arg
   609         -        {type.arg name}
   610         -    } -nulldefault]
   611         -
   612         -    Twapi_NetLocalGroupMembers 1 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] $accts
   613         -}
   614         -
   615         -
   616         -# Get rights for an account
   617         -proc twapi::get_account_rights {account args} {
   618         -    array set opts [parseargs args {
   619         -        {system.arg ""}
   620         -    } -maxleftover 0]
   621         -
   622         -    set sid [map_account_to_sid $account -system $opts(system)]
   623         -
   624         -    trap {
   625         -        set lsah [get_lsa_policy_handle -system $opts(system) -access policy_lookup_names]
   626         -        return [Twapi_LsaEnumerateAccountRights $lsah $sid]
   627         -    } onerror {TWAPI_WIN32 2} {
   628         -        # No specific rights for this account
   629         -        return [list ]
   630         -    } finally {
   631         -        if {[info exists lsah]} {
   632         -            close_lsa_policy_handle $lsah
   633         -        }
   634         -    }
   635         -}
   636         -
   637         -# Get accounts having a specific right
   638         -proc twapi::find_accounts_with_right {right args} {
   639         -    array set opts [parseargs args {
   640         -        {system.arg ""}
   641         -        name
   642         -    } -maxleftover 0]
   643         -
   644         -    trap {
   645         -        set lsah [get_lsa_policy_handle \
   646         -                      -system $opts(system) \
   647         -                      -access {
   648         -                          policy_lookup_names
   649         -                          policy_view_local_information
   650         -                      }]
   651         -        set accounts [list ]
   652         -        foreach sid [Twapi_LsaEnumerateAccountsWithUserRight $lsah $right] {
   653         -            if {$opts(name)} {
   654         -                if {[catch {lappend accounts [lookup_account_sid $sid -system $opts(system)]}]} {
   655         -                    # No mapping for SID - can happen if account has been
   656         -                    # deleted but LSA policy not updated accordingly
   657         -                    lappend accounts $sid
   658         -                }
   659         -            } else {
   660         -                lappend accounts $sid
   661         -            }
   662         -        }
   663         -        return $accounts
   664         -    } onerror {TWAPI_WIN32 259} {
   665         -        # No accounts have this right
   666         -        return [list ]
   667         -    } finally {
   668         -        if {[info exists lsah]} {
   669         -            close_lsa_policy_handle $lsah
   670         -        }
   671         -    }
   672         -
   673         -}
   674         -
   675         -# Add/remove rights to an account
   676         -proc twapi::_modify_account_rights {operation account rights args} {
   677         -    set switches {
   678         -        system.arg
   679         -        handle.arg
   680         -    }    
   681         -
   682         -    switch -exact -- $operation {
   683         -        add {
   684         -            # Nothing to do
   685         -        }
   686         -        remove {
   687         -            lappend switches all
   688         -        }
   689         -        default {
   690         -            error "Invalid operation '$operation' specified"
   691         -        }
   692         -    }
   693         -
   694         -    array set opts [parseargs args $switches -maxleftover 0]
   695         -
   696         -    if {[info exists opts(system)] && [info exists opts(handle)]} {
   697         -        error "Options -system and -handle may not be specified together"
   698         -    }
   699         -
   700         -    if {[info exists opts(handle)]} {
   701         -        set lsah $opts(handle)
   702         -        set sid $account
   703         -    } else {
   704         -        if {![info exists opts(system)]} {
   705         -            set opts(system) ""
   706         -        }
   707         -
   708         -        set sid [map_account_to_sid $account -system $opts(system)]
   709         -        # We need to open a policy handle ourselves. First try to open
   710         -        # with max privileges in case the account needs to be created
   711         -        # and then retry with lower privileges if that fails
   712         -        catch {
   713         -            set lsah [get_lsa_policy_handle \
   714         -                          -system $opts(system) \
   715         -                          -access {
   716         -                              policy_lookup_names
   717         -                              policy_create_account
   718         -                          }]
   719         -        }
   720         -        if {![info exists lsah]} {
   721         -            set lsah [get_lsa_policy_handle \
   722         -                          -system $opts(system) \
   723         -                          -access policy_lookup_names]
   724         -        }
   725         -    }
   726         -
   727         -    trap {
   728         -        if {$operation == "add"} {
   729         -            LsaAddAccountRights $lsah $sid $rights
   730         -        } else {
   731         -            LsaRemoveAccountRights $lsah $sid $opts(all) $rights
   732         -        }
   733         -    } finally {
   734         -        # Close the handle if we opened it
   735         -        if {! [info exists opts(handle)]} {
   736         -            close_lsa_policy_handle $lsah
   737         -        }
   738         -    }
   739         -}
   740         -
   741         -interp alias {} twapi::add_account_rights {} twapi::_modify_account_rights add
   742         -interp alias {} twapi::remove_account_rights {} twapi::_modify_account_rights remove
   743         -
   744         -# Return list of logon sesionss
   745         -proc twapi::find_logon_sessions {args} {
   746         -    array set opts [parseargs args {
   747         -        user.arg
   748         -        type.arg
   749         -        tssession.arg
   750         -    } -maxleftover 0]
   751         -
   752         -    set luids [LsaEnumerateLogonSessions]
   753         -    if {! ([info exists opts(user)] || [info exists opts(type)] ||
   754         -           [info exists opts(tssession)])} {
   755         -        return $luids
   756         -    }
   757         -
   758         -
   759         -    # Need to get the data for each session to see if it matches
   760         -    set result [list ]
   761         -    if {[info exists opts(user)]} {
   762         -        set sid [map_account_to_sid $opts(user)]
   763         -    }
   764         -    if {[info exists opts(type)]} {
   765         -        set logontypes [list ]
   766         -        foreach logontype $opts(type) {
   767         -            lappend logontypes [_logon_session_type_code $logontype]
   768         -        }
   769         -    }
   770         -
   771         -    foreach luid $luids {
   772         -        trap {
   773         -            unset -nocomplain session
   774         -            array set session [LsaGetLogonSessionData $luid]
   775         -
   776         -            # For the local system account, no data is returned on some
   777         -            # platforms
   778         -            if {[array size session] == 0} {
   779         -                set session(Sid) S-1-5-18; # SYSTEM
   780         -                set session(Session) 0
   781         -                set session(LogonType) 0
   782         -            }
   783         -            if {[info exists opts(user)] && $session(Sid) ne $sid} {
   784         -                continue;               # User id does not match
   785         -            }
   786         -
   787         -            if {[info exists opts(type)] && [lsearch -exact $logontypes $session(LogonType)] < 0} {
   788         -                continue;               # Type does not match
   789         -            }
   790         -
   791         -            if {[info exists opts(tssession)] && $session(Session) != $opts(tssession)} {
   792         -                continue;               # Term server session does not match
   793         -            }
   794         -
   795         -            lappend result $luid
   796         -
   797         -        } onerror {TWAPI_WIN32 1312} {
   798         -            # Session no longer exists. Just skip
   799         -            continue
   800         -        }
   801         -    }
   802         -
   803         -    return $result
   804         -}
   805         -
   806         -
   807         -# Return data for a logon session
   808         -proc twapi::get_logon_session_info {luid args} {
   809         -    array set opts [parseargs args {
   810         -        all
   811         -        authpackage
   812         -        dnsdomain
   813         -        logondomain
   814         -        logonid
   815         -        logonserver
   816         -        logontime
   817         -        type
   818         -        usersid
   819         -        user
   820         -        tssession
   821         -        userprincipal
   822         -    } -maxleftover 0]
   823         -
   824         -    array set session [LsaGetLogonSessionData $luid]
   825         -
   826         -    # Some fields may be missing on Win2K
   827         -    foreach fld {LogonServer DnsDomainName Upn} {
   828         -        if {![info exists session($fld)]} {
   829         -            set session($fld) ""
   830         -        }
   831         -    }
   832         -
   833         -    array set result [list ]
   834         -    foreach {opt index} {
   835         -        authpackage AuthenticationPackage
   836         -        dnsdomain   DnsDomainName
   837         -        logondomain LogonDomain
   838         -        logonid     LogonId
   839         -        logonserver LogonServer
   840         -        logontime   LogonTime
   841         -        type        LogonType
   842         -        usersid         Sid
   843         -        user        UserName
   844         -        tssession   Session
   845         -        userprincipal Upn
   846         -    } {
   847         -        if {$opts(all) || $opts($opt)} {
   848         -            set result(-$opt) $session($index)
   849         -        }
   850         -    }
   851         -
   852         -    if {[info exists result(-type)]} {
   853         -        set result(-type) [_logon_session_type_symbol $result(-type)]
   854         -    }
   855         -
   856         -    return [array get result]
   857         -}
   858         -
   859         -
   860         -
   861         -
   862         -# Set/reset the given bits in the usri3_flags field for a user account
   863         -# mask indicates the mask of bits to set. values indicates the values
   864         -# of those bits
   865         -proc twapi::_change_user_info_flags {username mask values args} {
   866         -    array set opts [parseargs args {
   867         -        system.arg
   868         -    } -nulldefault -maxleftover 0]
   869         -
   870         -    # Get current flags
   871         -    set flags [USER_INFO_1 -flags [NetUserGetInfo $opts(system) $username 1]]
   872         -
   873         -    # Turn off mask bits and write flags back
   874         -    set flags [expr {$flags & (~ $mask)}]
   875         -    # Set the specified bits
   876         -    set flags [expr {$flags | ($values & $mask)}]
   877         -
   878         -    # Write new flags back
   879         -    Twapi_NetUserSetInfo 1008 $opts(system) $username $flags
   880         -}
   881         -
   882         -# Returns the logon session type value for a symbol
   883         -twapi::proc* twapi::_logon_session_type_code {type} {
   884         -    variable _logon_session_type_map
   885         -    # Variable that maps logon session type codes to integer values
   886         -    # Position of each symbol gives its corresponding type value
   887         -    # See ntsecapi.h for definitions
   888         -    set _logon_session_type_map {
   889         -        0
   890         -        1
   891         -        interactive
   892         -        network
   893         -        batch
   894         -        service
   895         -        proxy
   896         -        unlockworkstation
   897         -        networkclear
   898         -        newcredentials
   899         -        remoteinteractive
   900         -        cachedinteractive
   901         -        cachedremoteinteractive
   902         -        cachedunlockworkstation
   903         -    }
   904         -} {
   905         -    variable _logon_session_type_map
   906         -
   907         -    # Type may be an integer or a token
   908         -    set code [lsearch -exact $_logon_session_type_map $type]
   909         -    if {$code >= 0} {
   910         -        return $code
   911         -    }
   912         -
   913         -    if {![string is integer -strict $type]} {
   914         -        badargs! "Invalid logon session type '$type' specified" 3
   915         -    }
   916         -    return $type
   917         -}
   918         -
   919         -# Returns the logon session type symbol for an integer value
   920         -proc twapi::_logon_session_type_symbol {code} {
   921         -    variable _logon_session_type_map
   922         -    _logon_session_type_code interactive; # Just to init _logon_session_type_map
   923         -    set symbol [lindex $_logon_session_type_map $code]
   924         -    if {$symbol eq ""} {
   925         -        return $code
   926         -    } else {
   927         -        return $symbol
   928         -    }
   929         -}
   930         -
   931         -proc twapi::_set_user_priv_level {username priv_level args} {
   932         -
   933         -    array set opts [parseargs args {system.arg} -nulldefault]
   934         -
   935         -    if {0} {
   936         -        # FOr some reason NetUserSetInfo cannot change priv level
   937         -        # Tried it separately with a simple C program. So this code
   938         -        # is commented out and we use group membership to achieve
   939         -        # the desired result
   940         -        # Note: - latest MSDN confirms above
   941         -        if {![info exists twapi::priv_level_map($priv_level)]} {
   942         -            error "Invalid privilege level value '$priv_level' specified. Must be one of [join [array names twapi::priv_level_map] ,]"
   943         -        }
   944         -        set priv $twapi::priv_level_map($priv_level)
   945         -
   946         -        Twapi_NetUserSetInfo_priv $opts(system) $username $priv
   947         -    } else {
   948         -        # Don't hardcode group names - reverse map SID's instead for 
   949         -        # non-English systems. Also note that since
   950         -        # we might be lowering privilege level, we have to also
   951         -        # remove from higher privileged groups
   952         -
   953         -        switch -exact -- $priv_level {
   954         -            guest {
   955         -                # administrators users
   956         -                set outgroups {S-1-5-32-544 S-1-5-32-545}
   957         -                # guests
   958         -                set ingroup S-1-5-32-546
   959         -            }
   960         -            user  {
   961         -                # administrators
   962         -                set outgroups {S-1-5-32-544}
   963         -                # users
   964         -                set ingroup S-1-5-32-545
   965         -            }
   966         -            admin {
   967         -                set outgroups {}
   968         -                set ingroup S-1-5-32-544
   969         -            }
   970         -            default {error "Invalid privilege level '$priv_level'. Must be one of 'guest', 'user' or 'admin'"}
   971         -        }
   972         -        # Remove from higher priv groups
   973         -        foreach outgroup $outgroups {
   974         -            # Get the potentially localized name of the group
   975         -            set group [lookup_account_sid $outgroup -system $opts(system)]
   976         -            # Catch since may not be member of that group
   977         -            catch {remove_member_from_local_group $group $username -system $opts(system)}
   978         -        }
   979         -
   980         -        # Get the potentially localized name of the group to be added
   981         -        set group [lookup_account_sid $ingroup -system $opts(system)]
   982         -        add_member_to_local_group $group $username -system $opts(system)
   983         -    }
   984         -}
   985         -
   986         -proc twapi::_map_userinfo_flags {flags} {
   987         -    # UF_LOCKOUT -> 0x10, UF_ACCOUNTDISABLE -> 0x2
   988         -    if {$flags & 0x2} {
   989         -        set status disabled
   990         -    } elseif {$flags & 0x10} {
   991         -        set status locked
   992         -    } else {
   993         -        set status enabled
   994         -    }
   995         -
   996         -    #define UF_TEMP_DUPLICATE_ACCOUNT       0x0100
   997         -    #define UF_NORMAL_ACCOUNT               0x0200
   998         -    #define UF_INTERDOMAIN_TRUST_ACCOUNT    0x0800
   999         -    #define UF_WORKSTATION_TRUST_ACCOUNT    0x1000
  1000         -    #define UF_SERVER_TRUST_ACCOUNT         0x2000
  1001         -    if {$flags & 0x0200} {
  1002         -        set type normal
  1003         -    } elseif {$flags & 0x0100} {
  1004         -        set type duplicate
  1005         -    } elseif {$flags & 0x0800} {
  1006         -        set type interdomain_trust
  1007         -    } elseif {$flags & 0x1000} {
  1008         -        set type workstation_trust
  1009         -    } elseif {$flags & 0x2000} {
  1010         -        set type server_trust
  1011         -    } else {
  1012         -        set type unknown
  1013         -    }
  1014         -
  1015         -    set pw {}
  1016         -    #define UF_PASSWD_NOTREQD                  0x0020
  1017         -    if {$flags & 0x0020} {
  1018         -        lappend pw not_required
  1019         -    }
  1020         -    #define UF_PASSWD_CANT_CHANGE              0x0040
  1021         -    if {$flags & 0x0040} {
  1022         -        lappend pw cannot_change
  1023         -    }
  1024         -    #define UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED 0x0080
  1025         -    if {$flags & 0x0080} {
  1026         -        lappend pw encrypted_text_allowed
  1027         -    }
  1028         -    #define UF_DONT_EXPIRE_PASSWD                         0x10000
  1029         -    if {$flags & 0x10000} {
  1030         -        lappend pw no_expiry
  1031         -    }
  1032         -    #define UF_SMARTCARD_REQUIRED                         0x40000
  1033         -    if {$flags & 0x40000} {
  1034         -        lappend pw smartcard_required
  1035         -    }
  1036         -    #define UF_PASSWORD_EXPIRED                          0x800000
  1037         -    if {$flags & 0x800000} {
  1038         -        lappend pw expired
  1039         -    }
  1040         -
  1041         -    return [list -status $status -type $type -password_attrs $pw]
  1042         -}
  1043         -
  1044         -twapi::proc* twapi::_define_user_modals {} {
  1045         -    struct _USER_MODALS_INFO_0 {
  1046         -        DWORD min_passwd_len;
  1047         -        DWORD max_passwd_age;
  1048         -        DWORD min_passwd_age;
  1049         -        DWORD force_logoff;
  1050         -        DWORD password_hist_len;
  1051         -    }
  1052         -    struct _USER_MODALS_INFO_1 {
  1053         -        DWORD  role;
  1054         -        LPWSTR primary;
  1055         -    }
  1056         -    struct _USER_MODALS_INFO_2 {
  1057         -        LPWSTR domain_name;
  1058         -        PSID   domain_id;
  1059         -    }
  1060         -    struct _USER_MODALS_INFO_3 {
  1061         -        DWORD lockout_duration;
  1062         -        DWORD lockout_observation_window;
  1063         -        DWORD lockout_threshold;
  1064         -    }
  1065         -    struct _USER_MODALS_INFO_1001 {
  1066         -        DWORD min_passwd_len;
  1067         -    }
  1068         -    struct _USER_MODALS_INFO_1002 {
  1069         -        DWORD max_passwd_age;
  1070         -    }
  1071         -    struct _USER_MODALS_INFO_1003 {
  1072         -        DWORD min_passwd_age;
  1073         -    }
  1074         -    struct _USER_MODALS_INFO_1004 {
  1075         -        DWORD force_logoff;
  1076         -    }
  1077         -    struct _USER_MODALS_INFO_1005 {
  1078         -        DWORD password_hist_len;
  1079         -    }
  1080         -    struct _USER_MODALS_INFO_1006 {
  1081         -        DWORD role;
  1082         -    }
  1083         -    struct _USER_MODALS_INFO_1007 {
  1084         -        LPWSTR primary;
  1085         -    }
  1086         -} {
  1087         -}
  1088         -
  1089         -twapi::proc* twapi::get_password_policy {{server_name ""}} {
  1090         -    _define_user_modals
  1091         -} {
  1092         -    set result [NetUserModalsGet $server_name 0 [_USER_MODALS_INFO_0]]
  1093         -    dict with result {
  1094         -        if {$force_logoff == 4294967295 || $force_logoff == -1} {
  1095         -            set force_logoff never
  1096         -        }
  1097         -        if {$max_passwd_age == 4294967295 || $max_passwd_age == -1} {
  1098         -            set max_passwd_age none
  1099         -        }
  1100         -    }
  1101         -    return $result
  1102         -}
  1103         -
  1104         -# TBD - doc & test
  1105         -twapi::proc* twapi::get_system_role {{server_name ""}} {
  1106         -    _define_user_modals
  1107         -} {
  1108         -    set result [NetUserModalsGet $server_name 1 [_USER_MODALS_INFO_1]]
  1109         -    dict set result role [dict* {
  1110         -        0 standalone 1 member 2 backup 3 primary
  1111         -    } [dict get $result role]]
  1112         -    return $result
  1113         -}
  1114         -
  1115         -# TBD - doc & test
  1116         -twapi::proc* twapi::get_system_domain {{server_name ""}} {
  1117         -    _define_user_modals
  1118         -} {
  1119         -    return [NetUserModalsGet $server_name 2 [_USER_MODALS_INFO_2]]
  1120         -}
  1121         -
  1122         -twapi::proc* twapi::get_lockout_policy {{server_name ""}} {
  1123         -    _define_user_modals
  1124         -} {
  1125         -    return [NetUserModalsGet $server_name 3 [_USER_MODALS_INFO_3]]
  1126         -}
  1127         -
  1128         -# TBD - doc & test
  1129         -twapi::proc* twapi::set_password_policy {name val {server_name ""}} {
  1130         -    _define_user_modals
  1131         -} {
  1132         -    switch -exact $name {
  1133         -        min_passwd_len {
  1134         -            NetUserModalsSet $server_name 1001 [_USER_MODALS_INFO_1001 $val]
  1135         -        }
  1136         -        max_passwd_age {
  1137         -            if {$val eq "none"} {
  1138         -                set val 4294967295
  1139         -            }
  1140         -            NetUserModalsSet $server_name 1002 [_USER_MODALS_INFO_1002 $val]
  1141         -        }
  1142         -        min_passwd_age {
  1143         -            NetUserModalsSet $server_name 1003 [_USER_MODALS_INFO_1003 $val]
  1144         -        }
  1145         -        force_logoff {
  1146         -            if {$val eq "never"} {
  1147         -                set val 4294967295
  1148         -            }
  1149         -            NetUserModalsSet $server_name 1004 [_USER_MODALS_INFO_1004 $val]
  1150         -        }
  1151         -        password_hist_len {
  1152         -            NetUserModalsSet $server_name 1005 [_USER_MODALS_INFO_1005 $val]
  1153         -        }
  1154         -    }
  1155         -}
  1156         -
  1157         -# TBD - doc & test
  1158         -twapi::proc* twapi::set_lockout_policy {duration observe_window threshold {server_name ""}} {
  1159         -    _define_user_modals
  1160         -} {
  1161         -    NetUserModalsSet $server_name 3 [_USER_MODALS_INFO_3 $duration $observe_window $threshold]
  1162         -}

Deleted winlibs/twapi/adsi.tcl.

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

Deleted winlibs/twapi/apputil.tcl.

     1         -#
     2         -# Copyright (c) 2003-2012, Ashok P. Nadkarni
     3         -# All rights reserved.
     4         -#
     5         -# See the file LICENSE for license
     6         -
     7         -namespace eval twapi {}
     8         -
     9         -# Get the command line
    10         -proc twapi::get_command_line {} {
    11         -    return [GetCommandLineW]
    12         -}
    13         -
    14         -# Parse the command line
    15         -proc twapi::get_command_line_args {cmdline} {
    16         -    # Special check for empty line. CommandLinetoArgv returns process
    17         -    # exe name in this case.
    18         -    if {[string length $cmdline] == 0} {
    19         -        return [list ]
    20         -    }
    21         -    return [CommandLineToArgv $cmdline]
    22         -}
    23         -
    24         -# Read an ini file int
    25         -proc twapi::read_inifile_key {section key args} {
    26         -    array set opts [parseargs args {
    27         -        {default.arg ""}
    28         -        inifile.arg
    29         -    } -maxleftover 0]
    30         -
    31         -    if {[info exists opts(inifile)]} {
    32         -        set values [read_inifile_section $section -inifile $opts(inifile)]
    33         -    } else {
    34         -        set values [read_inifile_section $section]
    35         -    }
    36         -
    37         -    # Cannot use kl_get or arrays here because we want case insensitive compare
    38         -    foreach {k val} $values {
    39         -        if {[string equal -nocase $key $k]} {
    40         -            return $val
    41         -        }
    42         -    }
    43         -    return $opts(default)
    44         -}
    45         -
    46         -# Write an ini file string
    47         -proc twapi::write_inifile_key {section key value args} {
    48         -    array set opts [parseargs args {
    49         -        inifile.arg
    50         -    } -maxleftover 0]
    51         -
    52         -    if {[info exists opts(inifile)]} {
    53         -        WritePrivateProfileString $section $key $value $opts(inifile)
    54         -    } else {
    55         -        WriteProfileString $section $key $value
    56         -    }
    57         -}
    58         -
    59         -# Delete an ini file string
    60         -proc twapi::delete_inifile_key {section key args} {
    61         -    array set opts [parseargs args {
    62         -        inifile.arg
    63         -    } -maxleftover 0]
    64         -
    65         -    if {[info exists opts(inifile)]} {
    66         -        WritePrivateProfileString $section $key $twapi::nullptr $opts(inifile)
    67         -    } else {
    68         -        WriteProfileString $section $key $twapi::nullptr
    69         -    }
    70         -}
    71         -
    72         -# Get names of the sections in an inifile
    73         -proc twapi::read_inifile_section_names {args} {
    74         -    array set opts [parseargs args {
    75         -        inifile.arg
    76         -    } -nulldefault -maxleftover 0]
    77         -
    78         -    return [GetPrivateProfileSectionNames $opts(inifile)]
    79         -}
    80         -
    81         -# Get keys and values in a section in an inifile
    82         -proc twapi::read_inifile_section {section args} {
    83         -    array set opts [parseargs args {
    84         -        inifile.arg
    85         -    } -nulldefault -maxleftover 0]
    86         -
    87         -    set result [list ]
    88         -    foreach line [GetPrivateProfileSection $section $opts(inifile)] {
    89         -        set pos [string first "=" $line]
    90         -        if {$pos >= 0} {
    91         -            lappend result [string range $line 0 [expr {$pos-1}]] [string range $line [incr pos] end]
    92         -        }
    93         -    }
    94         -    return $result
    95         -}
    96         -
    97         -
    98         -# Delete an ini file section
    99         -proc twapi::delete_inifile_section {section args} {
   100         -    variable nullptr
   101         -
   102         -    array set opts [parseargs args {
   103         -        inifile.arg
   104         -    }]
   105         -
   106         -    if {[info exists opts(inifile)]} {
   107         -        WritePrivateProfileString $section $nullptr $nullptr $opts(inifile)
   108         -    } else {
   109         -        WriteProfileString $section $nullptr $nullptr
   110         -    }
   111         -}
   112         -
   113         -
   114         -

Deleted winlibs/twapi/base.tcl.

     1         -#
     2         -# Copyright (c) 2012-2014, Ashok P. Nadkarni
     3         -# All rights reserved.
     4         -#
     5         -# See the file LICENSE for license
     6         -
     7         -# Commands in twapi_base module
     8         -
     9         -namespace eval twapi {
    10         -    # Map of Sid integer type to Sid type name
    11         -    array set sid_type_names {
    12         -        1 user 
    13         -        2 group
    14         -        3 domain 
    15         -        4 alias 
    16         -        5 wellknowngroup
    17         -        6 deletedaccount
    18         -        7 invalid
    19         -        8 unknown
    20         -        9 computer
    21         -        10 label
    22         -    }
    23         -
    24         -    # Cache mapping account names to SIDs. Dict keyed by system and name
    25         -    variable _name_to_sid_cache {}
    26         -
    27         -    # Cache mapping SIDs to account names. Dict keyed by system and SID
    28         -    variable _sid_to_name_cache {}
    29         -
    30         -}
    31         -
    32         -
    33         -
    34         -# Return major minor servicepack as a quad list
    35         -proc twapi::get_os_version {} {
    36         -    array set verinfo [GetVersionEx]
    37         -    return [list $verinfo(dwMajorVersion) $verinfo(dwMinorVersion) \
    38         -                $verinfo(wServicePackMajor) $verinfo(wServicePackMinor)]
    39         -}
    40         -
    41         -# Returns true if the OS version is at least $major.$minor.$sp
    42         -proc twapi::min_os_version {major {minor 0} {spmajor 0} {spminor 0}} {
    43         -    lassign  [twapi::get_os_version]  osmajor osminor osspmajor osspminor
    44         -
    45         -    if {$osmajor > $major} {return 1}
    46         -    if {$osmajor < $major} {return 0}
    47         -    if {$osminor > $minor} {return 1}
    48         -    if {$osminor < $minor} {return 0}
    49         -    if {$osspmajor > $spmajor} {return 1}
    50         -    if {$osspmajor < $spmajor} {return 0}
    51         -    if {$osspminor > $spminor} {return 1}
    52         -    if {$osspminor < $spminor} {return 0}
    53         -
    54         -    # Same version, ok
    55         -    return 1
    56         -}
    57         -
    58         -# Convert a LARGE_INTEGER time value (100ns since 1601) to a formatted date
    59         -# time
    60         -interp alias {} twapi::large_system_time_to_secs {} twapi::large_system_time_to_secs_since_1970
    61         -proc twapi::large_system_time_to_secs_since_1970 {ns100 {fraction false}} {
    62         -    # No. 100ns units between 1601 to 1970 = 116444736000000000
    63         -    set ns100_since_1970 [expr {$ns100-116444736000000000}]
    64         -
    65         -    set secs_since_1970 [expr {$ns100_since_1970/10000000}]
    66         -    if {$fraction} {
    67         -        append secs_since_1970 .[string range $ns100 end-6 end]
    68         -    }
    69         -    return $secs_since_1970
    70         -}
    71         -
    72         -proc twapi::secs_since_1970_to_large_system_time {secs} {
    73         -    # No. 100ns units between 1601 to 1970 = 116444736000000000
    74         -    return [expr {($secs * 10000000) + 116444736000000000}]
    75         -}
    76         -
    77         -# Map a Windows error code to a string
    78         -proc twapi::map_windows_error {code} {
    79         -    # Trim trailing CR/LF
    80         -    return [string trimright [twapi::Twapi_MapWindowsErrorToString $code] "\r\n"]
    81         -}
    82         -
    83         -# Load given library
    84         -proc twapi::load_library {path args} {
    85         -    array set opts [parseargs args {
    86         -        dontresolverefs
    87         -        datafile
    88         -        alteredpath
    89         -    }]
    90         -
    91         -    set flags 0
    92         -    if {$opts(dontresolverefs)} {
    93         -        setbits flags 1;                # DONT_RESOLVE_DLL_REFERENCES
    94         -    }
    95         -    if {$opts(datafile)} {
    96         -        setbits flags 2;                # LOAD_LIBRARY_AS_DATAFILE
    97         -    }
    98         -    if {$opts(alteredpath)} {
    99         -        setbits flags 8;                # LOAD_WITH_ALTERED_SEARCH_PATH
   100         -    }
   101         -
   102         -    # LoadLibrary always wants backslashes
   103         -    set path [file nativename $path]
   104         -    return [LoadLibraryEx $path $flags]
   105         -}
   106         -
   107         -# Free library opened with load_library
   108         -proc twapi::free_library {libh} {
   109         -    FreeLibrary $libh
   110         -}
   111         -
   112         -# Format message string - will raise exception if insufficient number
   113         -# of arguments
   114         -proc twapi::_unsafe_format_message {args} {
   115         -    array set opts [parseargs args {
   116         -        module.arg
   117         -        fmtstring.arg
   118         -        messageid.arg
   119         -        langid.arg
   120         -        params.arg
   121         -        includesystem
   122         -        ignoreinserts
   123         -        width.int
   124         -    } -nulldefault -maxleftover 0]
   125         -
   126         -    set flags 0
   127         -
   128         -    if {$opts(module) == ""} {
   129         -        if {$opts(fmtstring) == ""} {
   130         -            # If neither -module nor -fmtstring specified, message is formatted
   131         -            # from the system
   132         -            set opts(module) NULL
   133         -            setbits flags 0x1000;       # FORMAT_MESSAGE_FROM_SYSTEM
   134         -        } else {
   135         -            setbits flags 0x400;        # FORMAT_MESSAGE_FROM_STRING
   136         -            if {$opts(includesystem) || $opts(messageid) != "" || $opts(langid) != ""} {
   137         -                error "Options -includesystem, -messageid and -langid cannot be used with -fmtstring"
   138         -            }
   139         -        }
   140         -    } else {
   141         -        if {$opts(fmtstring) != ""} {
   142         -            error "Options -fmtstring and -module cannot be used together"
   143         -        }
   144         -        setbits flags 0x800;        # FORMAT_MESSAGE_FROM_HMODULE
   145         -        if {$opts(includesystem)} {
   146         -            # Also include system in search
   147         -            setbits flags 0x1000;       # FORMAT_MESSAGE_FROM_SYSTEM
   148         -        }
   149         -    }
   150         -
   151         -    if {$opts(ignoreinserts)} {
   152         -        setbits flags 0x200;            # FORMAT_MESSAGE_IGNORE_INSERTS
   153         -    }
   154         -
   155         -    if {$opts(width) > 254} {
   156         -        error "Invalid value for option -width. Must be -1, 0, or a positive integer less than 255"
   157         -    }
   158         -    if {$opts(width) < 0} {
   159         -        # Negative width means no width restrictions
   160         -        set opts(width) 255;                  # 255 -> no restrictions
   161         -    }
   162         -    incr flags $opts(width);                  # Width goes in low byte of flags
   163         -
   164         -    if {$opts(fmtstring) != ""} {
   165         -        return [FormatMessageFromString $flags $opts(fmtstring) $opts(params)]
   166         -    } else {
   167         -        if {![string is integer -strict $opts(messageid)]} {
   168         -            error "Unspecified or invalid value for -messageid option. Must be an integer value"
   169         -        }
   170         -        if {$opts(langid) == ""} { set opts(langid) 0 }
   171         -        if {![string is integer -strict $opts(langid)]} {
   172         -            error "Unspecfied or invalid value for -langid option. Must be an integer value"
   173         -        }
   174         -
   175         -        # Check if $opts(module) is a file or module handle (pointer)
   176         -        if {[pointer? $opts(module)]} {
   177         -            return  [FormatMessageFromModule $flags $opts(module) \
   178         -                         $opts(messageid) $opts(langid) $opts(params)]
   179         -        } else {
   180         -            set hmod [load_library $opts(module) -datafile]
   181         -            trap {
   182         -                set message  [FormatMessageFromModule $flags $hmod \
   183         -                                  $opts(messageid) $opts(langid) $opts(params)]
   184         -            } finally {
   185         -                free_library $hmod
   186         -            }
   187         -            return $message
   188         -        }
   189         -    }
   190         -}
   191         -
   192         -# Format message string
   193         -proc twapi::format_message {args} {
   194         -    array set opts [parseargs args {
   195         -        params.arg
   196         -        fmtstring.arg
   197         -        width.int
   198         -        ignoreinserts
   199         -    } -ignoreunknown]
   200         -
   201         -    # TBD - document - if no params specified, different from params = {}
   202         -
   203         -    # If a format string is specified, other options do not matter
   204         -    # except for -width. In that case, we do not call FormatMessage
   205         -    # at all
   206         -    if {[info exists opts(fmtstring)]} {
   207         -        # If -width specifed, call FormatMessage
   208         -        if {[info exists opts(width)] && $opts(width)} {
   209         -            set msg [_unsafe_format_message -ignoreinserts -fmtstring $opts(fmtstring) -width $opts(width) {*}$args]
   210         -        } else {
   211         -            set msg $opts(fmtstring)
   212         -        }
   213         -    } else {
   214         -        # Not -fmtstring, retrieve from message file
   215         -        if {[info exists opts(width)]} {
   216         -            set msg [_unsafe_format_message -ignoreinserts -width $opts(width) {*}$args]
   217         -        } else {
   218         -            set msg [_unsafe_format_message -ignoreinserts {*}$args]
   219         -        }
   220         -    }
   221         -
   222         -    # If we are told to ignore inserts, all done. Else replace them except
   223         -    # that if no param list, do not replace placeholder. This is NOT
   224         -    # the same as empty param list
   225         -    if {$opts(ignoreinserts) || ![info exists opts(params)]} {
   226         -        return $msg
   227         -    }
   228         -
   229         -    # TBD - cache fmtstring -> indices for performance
   230         -    set placeholder_indices [regexp -indices -all -inline {%(?:.|(?:[1-9][0-9]?(?:![^!]+!)?))} $msg]
   231         -
   232         -    if {[llength $placeholder_indices] == 0} {
   233         -        # No placeholders.
   234         -        return $msg
   235         -    }
   236         -
   237         -    # Use of * in format specifiers will change where the actual parameters
   238         -    # are positioned
   239         -    set num_asterisks 0
   240         -    set msg2 ""
   241         -    set prev_end 0
   242         -    foreach placeholder $placeholder_indices {
   243         -        lassign $placeholder start end
   244         -        # Append the stuff between previous placeholder and this one
   245         -        append msg2 [string range $msg $prev_end [expr {$start-1}]]
   246         -        set spec [string range $msg $start+1 $end]
   247         -        switch -exact -- [string index $spec 0] {
   248         -            % { append msg2 % }
   249         -            r { append msg2 \r }
   250         -            n { append msg2 \n }
   251         -            t { append msg2 \t }
   252         -            0 { 
   253         -                # No-op - %0 means to not add trailing newline
   254         -            }
   255         -            default {
   256         -                if {! [string is integer -strict [string index $spec 0]]} {
   257         -                    # Not a insert parameter. Just append the character
   258         -                    append msg2 $spec
   259         -                } else {
   260         -                    # Insert parameter
   261         -                    set fmt ""
   262         -                    scan $spec %d%s param_index fmt
   263         -                    # Note params are numbered starting with 1
   264         -                    incr param_index -1
   265         -                    # Format spec, if present, is enclosed in !. Get rid of them
   266         -                    set fmt [string trim $fmt "!"]
   267         -                    if {$fmt eq ""} {
   268         -                        # No fmt spec
   269         -                    } else {
   270         -                        # Since everything is a string in Tcl, we happily
   271         -                        # do not have to worry about type. However, the
   272         -                        # format spec could have * specifiers which will
   273         -                        # change the parameter indexing for subsequent
   274         -                        # arguments
   275         -                        incr num_asterisks [expr {[llength [split $fmt *]]-1}]
   276         -                        incr param_index $num_asterisks
   277         -                    }
   278         -                    # TBD - we ignore the actual format type
   279         -                    append msg2 [lindex $opts(params) $param_index]
   280         -                }                        
   281         -            }
   282         -        }                    
   283         -        set prev_end [incr end]
   284         -    }
   285         -    append msg2 [string range $msg $prev_end end]
   286         -    return $msg2
   287         -}
   288         -
   289         -# Revert to process token. In base package because used across many modules
   290         -proc twapi::revert_to_self {{opt ""}} {
   291         -    RevertToSelf
   292         -}
   293         -
   294         -# For backward compatibility
   295         -interp alias {} twapi::expand_environment_strings {} twapi::expand_environment_vars
   296         -
   297         -proc twapi::_init_security_defs {} {
   298         -    variable security_defs
   299         -
   300         -    # NOTE : the access definitions for those types that are included here
   301         -    # have been updated as of Windows 8.
   302         -    array set security_defs {
   303         -
   304         -        TOKEN_ASSIGN_PRIMARY           0x00000001
   305         -        TOKEN_DUPLICATE                0x00000002
   306         -        TOKEN_IMPERSONATE              0x00000004
   307         -        TOKEN_QUERY                    0x00000008
   308         -        TOKEN_QUERY_SOURCE             0x00000010
   309         -        TOKEN_ADJUST_PRIVILEGES        0x00000020
   310         -        TOKEN_ADJUST_GROUPS            0x00000040
   311         -        TOKEN_ADJUST_DEFAULT           0x00000080
   312         -        TOKEN_ADJUST_SESSIONID         0x00000100
   313         -
   314         -        TOKEN_ALL_ACCESS_WINNT         0x000F00FF
   315         -        TOKEN_ALL_ACCESS_WIN2K         0x000F01FF
   316         -        TOKEN_ALL_ACCESS               0x000F01FF
   317         -        TOKEN_READ                     0x00020008
   318         -        TOKEN_WRITE                    0x000200E0
   319         -        TOKEN_EXECUTE                  0x00020000
   320         -
   321         -        SYSTEM_MANDATORY_LABEL_NO_WRITE_UP         0x1
   322         -        SYSTEM_MANDATORY_LABEL_NO_READ_UP          0x2
   323         -        SYSTEM_MANDATORY_LABEL_NO_EXECUTE_UP       0x4
   324         -
   325         -        ACL_REVISION     2
   326         -        ACL_REVISION_DS  4
   327         -
   328         -        ACCESS_MAX_MS_V2_ACE_TYPE               0x3
   329         -        ACCESS_MAX_MS_V3_ACE_TYPE               0x4
   330         -        ACCESS_MAX_MS_V4_ACE_TYPE               0x8
   331         -        ACCESS_MAX_MS_V5_ACE_TYPE               0x11
   332         -
   333         -        STANDARD_RIGHTS_REQUIRED       0x000F0000
   334         -        STANDARD_RIGHTS_READ           0x00020000
   335         -        STANDARD_RIGHTS_WRITE          0x00020000
   336         -        STANDARD_RIGHTS_EXECUTE        0x00020000
   337         -        STANDARD_RIGHTS_ALL            0x001F0000
   338         -        SPECIFIC_RIGHTS_ALL            0x0000FFFF
   339         -
   340         -        GENERIC_READ                   0x80000000
   341         -        GENERIC_WRITE                  0x40000000
   342         -        GENERIC_EXECUTE                0x20000000
   343         -        GENERIC_ALL                    0x10000000
   344         -
   345         -        SERVICE_QUERY_CONFIG           0x00000001
   346         -        SERVICE_CHANGE_CONFIG          0x00000002
   347         -        SERVICE_QUERY_STATUS           0x00000004
   348         -        SERVICE_ENUMERATE_DEPENDENTS   0x00000008
   349         -        SERVICE_START                  0x00000010
   350         -        SERVICE_STOP                   0x00000020
   351         -        SERVICE_PAUSE_CONTINUE         0x00000040
   352         -        SERVICE_INTERROGATE            0x00000080
   353         -        SERVICE_USER_DEFINED_CONTROL   0x00000100
   354         -        SERVICE_ALL_ACCESS             0x000F01FF
   355         -
   356         -        SC_MANAGER_CONNECT             0x00000001
   357         -        SC_MANAGER_CREATE_SERVICE      0x00000002
   358         -        SC_MANAGER_ENUMERATE_SERVICE   0x00000004
   359         -        SC_MANAGER_LOCK                0x00000008
   360         -        SC_MANAGER_QUERY_LOCK_STATUS   0x00000010
   361         -        SC_MANAGER_MODIFY_BOOT_CONFIG  0x00000020
   362         -        SC_MANAGER_ALL_ACCESS          0x000F003F
   363         -
   364         -        KEY_QUERY_VALUE                0x00000001
   365         -        KEY_SET_VALUE                  0x00000002
   366         -        KEY_CREATE_SUB_KEY             0x00000004
   367         -        KEY_ENUMERATE_SUB_KEYS         0x00000008
   368         -        KEY_NOTIFY                     0x00000010
   369         -        KEY_CREATE_LINK                0x00000020
   370         -        KEY_WOW64_32KEY                0x00000200
   371         -        KEY_WOW64_64KEY                0x00000100
   372         -        KEY_WOW64_RES                  0x00000300
   373         -        KEY_READ                       0x00020019
   374         -        KEY_WRITE                      0x00020006
   375         -        KEY_EXECUTE                    0x00020019
   376         -        KEY_ALL_ACCESS                 0x000F003F
   377         -
   378         -        POLICY_VIEW_LOCAL_INFORMATION   0x00000001
   379         -        POLICY_VIEW_AUDIT_INFORMATION   0x00000002
   380         -        POLICY_GET_PRIVATE_INFORMATION  0x00000004
   381         -        POLICY_TRUST_ADMIN              0x00000008
   382         -        POLICY_CREATE_ACCOUNT           0x00000010
   383         -        POLICY_CREATE_SECRET            0x00000020
   384         -        POLICY_CREATE_PRIVILEGE         0x00000040
   385         -        POLICY_SET_DEFAULT_QUOTA_LIMITS 0x00000080
   386         -        POLICY_SET_AUDIT_REQUIREMENTS   0x00000100
   387         -        POLICY_AUDIT_LOG_ADMIN          0x00000200
   388         -        POLICY_SERVER_ADMIN             0x00000400
   389         -        POLICY_LOOKUP_NAMES             0x00000800
   390         -        POLICY_NOTIFICATION             0x00001000
   391         -        POLICY_READ                     0X00020006
   392         -        POLICY_WRITE                    0X000207F8
   393         -        POLICY_EXECUTE                  0X00020801
   394         -        POLICY_ALL_ACCESS               0X000F0FFF
   395         -
   396         -        DESKTOP_READOBJECTS         0x0001
   397         -        DESKTOP_CREATEWINDOW        0x0002
   398         -        DESKTOP_CREATEMENU          0x0004
   399         -        DESKTOP_HOOKCONTROL         0x0008
   400         -        DESKTOP_JOURNALRECORD       0x0010
   401         -        DESKTOP_JOURNALPLAYBACK     0x0020
   402         -        DESKTOP_ENUMERATE           0x0040
   403         -        DESKTOP_WRITEOBJECTS        0x0080
   404         -        DESKTOP_SWITCHDESKTOP       0x0100
   405         -
   406         -        WINSTA_ENUMDESKTOPS         0x0001
   407         -        WINSTA_READATTRIBUTES       0x0002
   408         -        WINSTA_ACCESSCLIPBOARD      0x0004
   409         -        WINSTA_CREATEDESKTOP        0x0008
   410         -        WINSTA_WRITEATTRIBUTES      0x0010
   411         -        WINSTA_ACCESSGLOBALATOMS    0x0020
   412         -        WINSTA_EXITWINDOWS          0x0040
   413         -        WINSTA_ENUMERATE            0x0100
   414         -        WINSTA_READSCREEN           0x0200
   415         -        WINSTA_ALL_ACCESS           0x37f
   416         -
   417         -        PROCESS_TERMINATE              0x0001
   418         -        PROCESS_CREATE_THREAD          0x0002
   419         -        PROCESS_SET_SESSIONID          0x0004
   420         -        PROCESS_VM_OPERATION           0x0008
   421         -        PROCESS_VM_READ                0x0010
   422         -        PROCESS_VM_WRITE               0x0020
   423         -        PROCESS_DUP_HANDLE             0x0040
   424         -        PROCESS_CREATE_PROCESS         0x0080
   425         -        PROCESS_SET_QUOTA              0x0100
   426         -        PROCESS_SET_INFORMATION        0x0200
   427         -        PROCESS_QUERY_INFORMATION      0x0400
   428         -        PROCESS_SUSPEND_RESUME         0x0800
   429         -
   430         -        THREAD_TERMINATE               0x00000001
   431         -        THREAD_SUSPEND_RESUME          0x00000002
   432         -        THREAD_GET_CONTEXT             0x00000008
   433         -        THREAD_SET_CONTEXT             0x00000010
   434         -        THREAD_SET_INFORMATION         0x00000020
   435         -        THREAD_QUERY_INFORMATION       0x00000040
   436         -        THREAD_SET_THREAD_TOKEN        0x00000080
   437         -        THREAD_IMPERSONATE             0x00000100
   438         -        THREAD_DIRECT_IMPERSONATION    0x00000200
   439         -        THREAD_SET_LIMITED_INFORMATION   0x00000400
   440         -        THREAD_QUERY_LIMITED_INFORMATION 0x00000800
   441         -
   442         -        EVENT_MODIFY_STATE             0x00000002
   443         -        EVENT_ALL_ACCESS               0x001F0003
   444         -
   445         -        SEMAPHORE_MODIFY_STATE         0x00000002
   446         -        SEMAPHORE_ALL_ACCESS           0x001F0003
   447         -
   448         -        MUTANT_QUERY_STATE             0x00000001
   449         -        MUTANT_ALL_ACCESS              0x001F0001
   450         -
   451         -        MUTEX_MODIFY_STATE             0x00000001
   452         -        MUTEX_ALL_ACCESS               0x001F0001
   453         -
   454         -        TIMER_QUERY_STATE              0x00000001
   455         -        TIMER_MODIFY_STATE             0x00000002
   456         -        TIMER_ALL_ACCESS               0x001F0003
   457         -
   458         -        FILE_READ_DATA                 0x00000001
   459         -        FILE_LIST_DIRECTORY            0x00000001
   460         -        FILE_WRITE_DATA                0x00000002
   461         -        FILE_ADD_FILE                  0x00000002
   462         -        FILE_APPEND_DATA               0x00000004
   463         -        FILE_ADD_SUBDIRECTORY          0x00000004
   464         -        FILE_CREATE_PIPE_INSTANCE      0x00000004
   465         -        FILE_READ_EA                   0x00000008
   466         -        FILE_WRITE_EA                  0x00000010
   467         -        FILE_EXECUTE                   0x00000020
   468         -        FILE_TRAVERSE                  0x00000020
   469         -        FILE_DELETE_CHILD              0x00000040
   470         -        FILE_READ_ATTRIBUTES           0x00000080
   471         -        FILE_WRITE_ATTRIBUTES          0x00000100
   472         -
   473         -        FILE_ALL_ACCESS                0x001F01FF
   474         -        FILE_GENERIC_READ              0x00120089
   475         -        FILE_GENERIC_WRITE             0x00120116
   476         -        FILE_GENERIC_EXECUTE           0x001200A0
   477         -
   478         -        DELETE                         0x00010000
   479         -        READ_CONTROL                   0x00020000
   480         -        WRITE_DAC                      0x00040000
   481         -        WRITE_OWNER                    0x00080000
   482         -        SYNCHRONIZE                    0x00100000
   483         -
   484         -        COM_RIGHTS_EXECUTE 1
   485         -        COM_RIGHTS_EXECUTE_LOCAL 2
   486         -        COM_RIGHTS_EXECUTE_REMOTE 4
   487         -        COM_RIGHTS_ACTIVATE_LOCAL 8
   488         -        COM_RIGHTS_ACTIVATE_REMOTE 16
   489         -    }
   490         -
   491         -    if {[min_os_version 6]} {
   492         -        array set security_defs {
   493         -            PROCESS_QUERY_LIMITED_INFORMATION      0x00001000
   494         -            PROCESS_ALL_ACCESS             0x001fffff
   495         -            THREAD_ALL_ACCESS              0x001fffff
   496         -        }
   497         -    } else {
   498         -        array set security_defs {
   499         -            PROCESS_ALL_ACCESS             0x001f0fff
   500         -            THREAD_ALL_ACCESS              0x001f03ff
   501         -        }
   502         -    }
   503         -
   504         -    # Make next call a no-op
   505         -    proc _init_security_defs {} {}
   506         -}
   507         -
   508         -# Map a set of access right symbols to a flag. Concatenates
   509         -# all the arguments, and then OR's the individual elements. Each
   510         -# element may either be a integer or one of the access rights
   511         -proc twapi::_access_rights_to_mask {args} {
   512         -    _init_security_defs
   513         -
   514         -    proc _access_rights_to_mask args {
   515         -        variable security_defs
   516         -        set rights 0
   517         -        foreach right [concat {*}$args] {
   518         -            # The mandatory label access rights are not in security_defs
   519         -            # because we do not want them to mess up the int->name mapping
   520         -            # for DACL's
   521         -            set right [dict* {
   522         -                no_write_up 1
   523         -                system_mandatory_label_no_write_up 1
   524         -                no_read_up 2
   525         -                system_mandatory_label_no_read_up  2
   526         -                no_execute_up 4
   527         -                system_mandatory_label_no_execute_up 4
   528         -            } $right]
   529         -            if {![string is integer $right]} {
   530         -                if {[catch {set right $security_defs([string toupper $right])}]} {
   531         -                    error "Invalid access right symbol '$right'"
   532         -                }
   533         -            }
   534         -            set rights [expr {$rights | $right}]
   535         -        }
   536         -        return $rights
   537         -    }
   538         -    return [_access_rights_to_mask {*}$args]
   539         -}
   540         -
   541         -
   542         -# Map an access mask to a set of rights
   543         -proc twapi::_access_mask_to_rights {access_mask {type ""}} {
   544         -    _init_security_defs
   545         -
   546         -    proc _access_mask_to_rights {access_mask {type ""}} {
   547         -        variable security_defs
   548         -
   549         -        set rights [list ]
   550         -
   551         -        if {$type eq "mandatory_label"} {
   552         -            if {$access_mask & 1} {
   553         -                lappend rights system_mandatory_label_no_write_up
   554         -            }
   555         -            if {$access_mask & 2} {
   556         -                lappend rights system_mandatory_label_no_read_up
   557         -            }
   558         -            if {$access_mask & 4} {
   559         -                lappend rights system_mandatory_label_no_execute_up
   560         -            }
   561         -            return $rights
   562         -        }
   563         -
   564         -        # The returned list will include rights that map to multiple bits
   565         -        # as well as the individual bits. We first add the multiple bits
   566         -        # and then the individual bits (since we clear individual bits
   567         -        # after adding)
   568         -
   569         -        #
   570         -        # Check standard multiple bit masks
   571         -        #
   572         -        foreach x {STANDARD_RIGHTS_REQUIRED STANDARD_RIGHTS_READ STANDARD_RIGHTS_WRITE STANDARD_RIGHTS_EXECUTE STANDARD_RIGHTS_ALL SPECIFIC_RIGHTS_ALL} {
   573         -            if {($security_defs($x) & $access_mask) == $security_defs($x)} {
   574         -                lappend rights [string tolower $x]
   575         -            }
   576         -        }
   577         -
   578         -        #
   579         -        # Check type specific multiple bit masks.
   580         -        #
   581         -        
   582         -        set type_mask_map {
   583         -            file {FILE_ALL_ACCESS FILE_GENERIC_READ FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE}
   584         -            process {PROCESS_ALL_ACCESS}
   585         -            pipe {FILE_ALL_ACCESS}
   586         -            policy {POLICY_READ POLICY_WRITE POLICY_EXECUTE POLICY_ALL_ACCESS}
   587         -            registry {KEY_READ KEY_WRITE KEY_EXECUTE KEY_ALL_ACCESS}
   588         -            service {SERVICE_ALL_ACCESS}
   589         -            thread {THREAD_ALL_ACCESS}
   590         -            token {TOKEN_READ TOKEN_WRITE TOKEN_EXECUTE TOKEN_ALL_ACCESS}
   591         -            desktop {}
   592         -            winsta {WINSTA_ALL_ACCESS}
   593         -        }
   594         -        if {[dict exists $type_mask_map $type]} {
   595         -            foreach x [dict get $type_mask_map $type] {
   596         -                if {($security_defs($x) & $access_mask) == $security_defs($x)} {
   597         -                    lappend rights [string tolower $x]
   598         -                }
   599         -            }
   600         -        }
   601         -
   602         -        #
   603         -        # OK, now map individual bits
   604         -
   605         -        # First map the common bits
   606         -        foreach x {DELETE READ_CONTROL WRITE_DAC WRITE_OWNER SYNCHRONIZE} {
   607         -            if {$security_defs($x) & $access_mask} {
   608         -                lappend rights [string tolower $x]
   609         -                resetbits access_mask $security_defs($x)
   610         -            }
   611         -        }
   612         -
   613         -        # Then the generic bits
   614         -        foreach x {GENERIC_READ GENERIC_WRITE GENERIC_EXECUTE GENERIC_ALL} {
   615         -            if {$security_defs($x) & $access_mask} {
   616         -                lappend rights [string tolower $x]
   617         -                resetbits access_mask $security_defs($x)
   618         -            }
   619         -        }
   620         -
   621         -        # Then the type specific
   622         -        set type_mask_map {
   623         -            file { FILE_READ_DATA FILE_WRITE_DATA FILE_APPEND_DATA
   624         -                FILE_READ_EA FILE_WRITE_EA FILE_EXECUTE
   625         -                FILE_DELETE_CHILD FILE_READ_ATTRIBUTES
   626         -                FILE_WRITE_ATTRIBUTES }
   627         -            pipe { FILE_READ_DATA FILE_WRITE_DATA FILE_CREATE_PIPE_INSTANCE
   628         -                FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES }
   629         -            service { SERVICE_QUERY_CONFIG SERVICE_CHANGE_CONFIG
   630         -                SERVICE_QUERY_STATUS SERVICE_ENUMERATE_DEPENDENTS
   631         -                SERVICE_START SERVICE_STOP SERVICE_PAUSE_CONTINUE
   632         -                SERVICE_INTERROGATE SERVICE_USER_DEFINED_CONTROL }
   633         -            registry { KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY
   634         -                KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK
   635         -                KEY_WOW64_32KEY KEY_WOW64_64KEY KEY_WOW64_RES }
   636         -            policy { POLICY_VIEW_LOCAL_INFORMATION POLICY_VIEW_AUDIT_INFORMATION
   637         -                POLICY_GET_PRIVATE_INFORMATION POLICY_TRUST_ADMIN
   638         -                POLICY_CREATE_ACCOUNT POLICY_CREATE_SECRET
   639         -                POLICY_CREATE_PRIVILEGE POLICY_SET_DEFAULT_QUOTA_LIMITS
   640         -                POLICY_SET_AUDIT_REQUIREMENTS POLICY_AUDIT_LOG_ADMIN
   641         -                POLICY_SERVER_ADMIN POLICY_LOOKUP_NAMES }
   642         -            process { PROCESS_TERMINATE PROCESS_CREATE_THREAD
   643         -                PROCESS_SET_SESSIONID PROCESS_VM_OPERATION
   644         -                PROCESS_VM_READ PROCESS_VM_WRITE PROCESS_DUP_HANDLE
   645         -                PROCESS_CREATE_PROCESS PROCESS_SET_QUOTA
   646         -                PROCESS_SET_INFORMATION PROCESS_QUERY_INFORMATION
   647         -                PROCESS_SUSPEND_RESUME} 
   648         -            thread { THREAD_TERMINATE THREAD_SUSPEND_RESUME
   649         -                THREAD_GET_CONTEXT THREAD_SET_CONTEXT
   650         -                THREAD_SET_INFORMATION THREAD_QUERY_INFORMATION
   651         -                THREAD_SET_THREAD_TOKEN THREAD_IMPERSONATE
   652         -                THREAD_DIRECT_IMPERSONATION
   653         -                THREAD_SET_LIMITED_INFORMATION
   654         -                THREAD_QUERY_LIMITED_INFORMATION }
   655         -            token { TOKEN_ASSIGN_PRIMARY TOKEN_DUPLICATE TOKEN_IMPERSONATE
   656         -                TOKEN_QUERY TOKEN_QUERY_SOURCE TOKEN_ADJUST_PRIVILEGES
   657         -                TOKEN_ADJUST_GROUPS TOKEN_ADJUST_DEFAULT TOKEN_ADJUST_SESSIONID }
   658         -            desktop { DESKTOP_READOBJECTS DESKTOP_CREATEWINDOW
   659         -                DESKTOP_CREATEMENU DESKTOP_HOOKCONTROL
   660         -                DESKTOP_JOURNALRECORD DESKTOP_JOURNALPLAYBACK
   661         -                DESKTOP_ENUMERATE DESKTOP_WRITEOBJECTS DESKTOP_SWITCHDESKTOP }
   662         -            windowstation { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES
   663         -                WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP
   664         -                WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS
   665         -                WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN }
   666         -            winsta { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES
   667         -                WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP
   668         -                WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS
   669         -                WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN }
   670         -            com { COM_RIGHTS_EXECUTE COM_RIGHTS_EXECUTE_LOCAL 
   671         -                COM_RIGHTS_EXECUTE_REMOTE COM_RIGHTS_ACTIVATE_LOCAL 
   672         -                COM_RIGHTS_ACTIVATE_REMOTE 
   673         -            }
   674         -        }
   675         -
   676         -        if {[min_os_version 6]} {
   677         -            dict lappend type_mask_map process PROCESS_QUERY_LIMITED_INFORMATION
   678         -        }
   679         -
   680         -        if {[dict exists $type_mask_map $type]} {
   681         -            foreach x [dict get $type_mask_map $type] {
   682         -                if {$security_defs($x) & $access_mask} {
   683         -                    lappend rights [string tolower $x]
   684         -                    # Reset the bit so is it not included in unknown bits below
   685         -                    resetbits access_mask $security_defs($x)
   686         -                }
   687         -            }
   688         -        }
   689         -
   690         -        # Finally add left over bits if any
   691         -        for {set i 0} {$i < 32} {incr i} {
   692         -            set x [expr {1 << $i}]
   693         -            if {$access_mask & $x} {
   694         -                lappend rights [hex32 $x]
   695         -            }
   696         -        }
   697         -
   698         -        return $rights
   699         -    }
   700         -
   701         -    return [_access_mask_to_rights $access_mask $type]
   702         -}
   703         -
   704         -# Map the symbolic CreateDisposition parameter of CreateFile to integer values
   705         -proc twapi::_create_disposition_to_code {sym} {
   706         -    if {[string is integer -strict $sym]} {
   707         -        return $sym
   708         -    }
   709         -    # CREATE_NEW          1
   710         -    # CREATE_ALWAYS       2
   711         -    # OPEN_EXISTING       3
   712         -    # OPEN_ALWAYS         4
   713         -    # TRUNCATE_EXISTING   5
   714         -    return [dict get {
   715         -        create_new 1
   716         -        create_always 2
   717         -        open_existing 3
   718         -        open_always 4
   719         -        truncate_existing 5} $sym]
   720         -}
   721         -
   722         -# Wrapper around CreateFile
   723         -proc twapi::create_file {path args} {
   724         -    array set opts [parseargs args {
   725         -        {access.arg {generic_read}}
   726         -        {share.arg {read write delete}}
   727         -        {inherit.bool 0}
   728         -        {secd.arg ""}
   729         -        {createdisposition.arg open_always}
   730         -        {flags.int 0}
   731         -        {templatefile.arg NULL}
   732         -    } -maxleftover 0]
   733         -
   734         -    set access_mode [_access_rights_to_mask $opts(access)]
   735         -    set share_mode [_share_mode_to_mask $opts(share)]
   736         -    set create_disposition [_create_disposition_to_code $opts(createdisposition)]
   737         -    return [CreateFile $path \
   738         -                $access_mode \
   739         -                $share_mode \
   740         -                [_make_secattr $opts(secd) $opts(inherit)] \
   741         -                $create_disposition \
   742         -                $opts(flags) \
   743         -                $opts(templatefile)]
   744         -}
   745         -
   746         -# Map a set of share mode symbols to a flag. Concatenates
   747         -# all the arguments, and then OR's the individual elements. Each
   748         -# element may either be a integer or one of the share modes
   749         -proc twapi::_share_mode_to_mask {modelist} {
   750         -    # Values correspond to FILE_SHARE_* defines
   751         -    return [_parse_symbolic_bitmask $modelist {read 1 write 2 delete 4}]
   752         -}
   753         -
   754         -# Construct a security attributes structure out of a security descriptor
   755         -# and inheritance. The command is here because we do not want to
   756         -# have to load the twapi_security package for the common case of
   757         -# null security attributes.
   758         -proc twapi::_make_secattr {secd inherit} {
   759         -    if {$inherit} {
   760         -        set sec_attr [list $secd 1]
   761         -    } else {
   762         -        if {[llength $secd] == 0} {
   763         -            # If a security descriptor not specified, keep
   764         -            # all security attributes as an empty list (ie. NULL)
   765         -            set sec_attr [list ]
   766         -        } else {
   767         -            set sec_attr [list $secd 0]
   768         -        }
   769         -    }
   770         -    return $sec_attr
   771         -}
   772         -
   773         -# Returns the sid, domain and type for an account
   774         -proc twapi::lookup_account_name {name args} {
   775         -    variable _name_to_sid_cache
   776         -
   777         -    # Fast path - no options specified and cached
   778         -    if {[llength $args] == 0 && [dict exists $_name_to_sid_cache "" $name]} {
   779         -        return [lindex [dict get $_name_to_sid_cache "" $name] 0]
   780         -    }
   781         -
   782         -    array set opts [parseargs args \
   783         -                        [list all \
   784         -                             sid \
   785         -                             domain \
   786         -                             type \
   787         -                             [list system.arg ""]\
   788         -                            ]]
   789         -
   790         -    if {! [dict exists $_name_to_sid_cache $opts(system) $name]} {
   791         -        dict set _name_to_sid_cache $opts(system) $name [LookupAccountName $opts(system) $name]
   792         -    }    
   793         -    lassign [dict get $_name_to_sid_cache $opts(system) $name] sid domain type
   794         -
   795         -    set result [list ]
   796         -    if {$opts(all) || $opts(domain)} {
   797         -        lappend result -domain $domain
   798         -    }
   799         -    if {$opts(all) || $opts(type)} {
   800         -        if {[info exists twapi::sid_type_names($type)]} {
   801         -            lappend result -type $twapi::sid_type_names($type)
   802         -        } else {
   803         -            # Could be the "logonid" dummy type we added above
   804         -            lappend result -type $type
   805         -        }
   806         -    }
   807         -
   808         -    if {$opts(all) || $opts(sid)} {
   809         -        lappend result -sid $sid
   810         -    }
   811         -
   812         -    # If no options specified, only return the sid/name
   813         -    if {[llength $result] == 0} {
   814         -        return $sid
   815         -    }
   816         -
   817         -    return $result
   818         -}
   819         -
   820         -
   821         -# Returns the name, domain and type for an account
   822         -proc twapi::lookup_account_sid {sid args} {
   823         -    variable _sid_to_name_cache
   824         -
   825         -    # Fast path - no options specified and cached
   826         -    if {[llength $args] == 0 && [dict exists $_sid_to_name_cache "" $sid]} {
   827         -        return [lindex [dict get $_sid_to_name_cache "" $sid] 0]
   828         -    }
   829         -
   830         -    array set opts [parseargs args \
   831         -                        [list all \
   832         -                             name \
   833         -                             domain \
   834         -                             type \
   835         -                             [list system.arg ""]\
   836         -                            ]]
   837         -
   838         -    if {! [dict exists $_sid_to_name_cache $opts(system) $sid]} {
   839         -        # Not in cache. Need to look up
   840         -
   841         -        # LookupAccountSid returns an error for this SID
   842         -        if {[is_valid_sid_syntax $sid] &&
   843         -            [string match -nocase "S-1-5-5-*" $sid]} {
   844         -            set name "Logon SID"
   845         -            set domain "NT AUTHORITY"
   846         -            set type "logonid"
   847         -            dict set _sid_to_name_cache $opts(system) $sid [list $name $domain $type]
   848         -        } else {
   849         -            set data [LookupAccountSid $opts(system) $sid]
   850         -            lassign $data name domain type
   851         -            dict set _sid_to_name_cache $opts(system) $sid $data
   852         -        }
   853         -    } else {
   854         -        lassign [dict get $_sid_to_name_cache $opts(system) $sid] name domain type
   855         -    }
   856         -
   857         -
   858         -    set result [list ]
   859         -    if {$opts(all) || $opts(domain)} {
   860         -        lappend result -domain $domain
   861         -    }
   862         -    if {$opts(all) || $opts(type)} {
   863         -        if {[info exists twapi::sid_type_names($type)]} {
   864         -            lappend result -type $twapi::sid_type_names($type)
   865         -        } else {
   866         -            # Could be the "logonid" dummy type we added above
   867         -            lappend result -type $type
   868         -        }
   869         -    }
   870         -
   871         -    if {$opts(all) || $opts(name)} {
   872         -        lappend result -name $name
   873         -    }
   874         -
   875         -    # If no options specified, only return the sid/name
   876         -    if {[llength $result] == 0} {
   877         -        return $name
   878         -    }
   879         -
   880         -    return $result
   881         -}
   882         -
   883         -# Returns the sid for a account - may be given as a SID or name
   884         -proc twapi::map_account_to_sid {account args} {
   885         -    array set opts [parseargs args {system.arg} -nulldefault]
   886         -
   887         -    # Treat empty account as null SID (self)
   888         -    if {[string length $account] == ""} {
   889         -        return ""
   890         -    }
   891         -
   892         -    if {[is_valid_sid_syntax $account]} {
   893         -        return $account
   894         -    } else {
   895         -        return [lookup_account_name $account -system $opts(system)]
   896         -    }
   897         -}
   898         -
   899         -
   900         -# Returns the name for a account - may be given as a SID or name
   901         -proc twapi::map_account_to_name {account args} {
   902         -    array set opts [parseargs args {system.arg} -nulldefault]
   903         -
   904         -    if {[is_valid_sid_syntax $account]} {
   905         -        return [lookup_account_sid $account -system $opts(system)]
   906         -    } else {
   907         -        # Verify whether a valid account by mapping to an sid
   908         -        if {[catch {map_account_to_sid $account -system $opts(system)}]} {
   909         -            # As a special case, change LocalSystem to SYSTEM. Some Windows
   910         -            # API's (such as services) return LocalSystem which cannot be
   911         -            # resolved by the security functions. This name is really the
   912         -            # same a the built-in SYSTEM
   913         -            if {$account == "LocalSystem"} {
   914         -                return "SYSTEM"
   915         -            }
   916         -            error "Unknown account '$account'"
   917         -        } 
   918         -        return $account
   919         -    }
   920         -}
   921         -
   922         -# Return the user account for the current process
   923         -proc twapi::get_current_user {{format -samcompatible}} {
   924         -
   925         -    set return_sid false
   926         -    switch -exact -- $format {
   927         -        -fullyqualifieddn {set format 1}
   928         -        -samcompatible {set format 2}
   929         -        -display {set format 3}
   930         -        -uniqueid {set format 6}
   931         -        -canonical {set format 7}
   932         -        -userprincipal {set format 8}
   933         -        -canonicalex {set format 9}
   934         -        -serviceprincipal {set format 10}
   935         -        -dnsdomain {set format 12}
   936         -        -sid {set format 2 ; set return_sid true}
   937         -        default {
   938         -            error "Unknown user name format '$format'"
   939         -        }
   940         -    }
   941         -
   942         -    set user [GetUserNameEx $format]
   943         -
   944         -    if {$return_sid} {
   945         -        return [map_account_to_sid $user]
   946         -    } else {
   947         -        return $user
   948         -    }
   949         -}
   950         -
   951         -# Get a new uuid
   952         -proc twapi::new_uuid {{opt ""}} {
   953         -    if {[string length $opt]} {
   954         -        if {[string equal $opt "-localok"]} {
   955         -            set local_ok 1
   956         -        } else {
   957         -            error "Invalid or unknown argument '$opt'"
   958         -        }
   959         -    } else {
   960         -        set local_ok 0
   961         -    }
   962         -    return [UuidCreate $local_ok] 
   963         -}
   964         -proc twapi::nil_uuid {} {
   965         -    return [UuidCreateNil]
   966         -}
   967         -
   968         -proc twapi::new_guid {} {
   969         -    return [canonicalize_guid [new_uuid]]
   970         -}
   971         -
   972         -# Get a handle to a LSA policy. TBD - document
   973         -proc twapi::get_lsa_policy_handle {args} {
   974         -    array set opts [parseargs args {
   975         -        {system.arg ""}
   976         -        {access.arg policy_read}
   977         -    } -maxleftover 0]
   978         -
   979         -    set access [_access_rights_to_mask $opts(access)]
   980         -    return [Twapi_LsaOpenPolicy $opts(system) $access]
   981         -}
   982         -
   983         -# Close a LSA policy handle. TBD - document
   984         -proc twapi::close_lsa_policy_handle {h} {
   985         -    LsaClose $h
   986         -    return
   987         -}
   988         -
   989         -# Eventlog stuff in the base package
   990         -
   991         -namespace eval twapi {
   992         -    # Keep track of event log handles - values are "r" or "w"
   993         -    variable eventlog_handles
   994         -    array set eventlog_handles {}
   995         -}
   996         -
   997         -# Open an eventlog for reading or writing
   998         -proc twapi::eventlog_open {args} {
   999         -    variable eventlog_handles
  1000         -
  1001         -    array set opts [parseargs args {
  1002         -        system.arg
  1003         -        source.arg
  1004         -        file.arg
  1005         -        write
  1006         -    } -nulldefault -maxleftover 0]
  1007         -    if {$opts(source) == ""} {
  1008         -        # Source not specified
  1009         -        if {$opts(file) == ""} {
  1010         -            # No source or file specified, default to current event log 
  1011         -            # using executable name as source
  1012         -            set opts(source) [file rootname [file tail [info nameofexecutable]]]
  1013         -        } else {
  1014         -            if {$opts(write)} {
  1015         -                error "Option -file may not be used with -write"
  1016         -            }
  1017         -        }
  1018         -    } else {
  1019         -        # Source explicitly specified
  1020         -        if {$opts(file) != ""} {
  1021         -            error "Option -file may not be used with -source"
  1022         -        }
  1023         -    }
  1024         -
  1025         -    if {$opts(write)} {
  1026         -        set handle [RegisterEventSource $opts(system) $opts(source)]
  1027         -        set mode write
  1028         -    } else {
  1029         -        if {$opts(source) != ""} {
  1030         -            set handle [OpenEventLog $opts(system) $opts(source)]
  1031         -        } else {
  1032         -            set handle [OpenBackupEventLog $opts(system) $opts(file)]
  1033         -        }
  1034         -        set mode read
  1035         -    }
  1036         -
  1037         -    set eventlog_handles($handle) $mode
  1038         -    return $handle
  1039         -}
  1040         -
  1041         -# Close an event log opened for writing
  1042         -proc twapi::eventlog_close {hevl} {
  1043         -    variable eventlog_handles
  1044         -
  1045         -    if {[_eventlog_valid_handle $hevl read]} {
  1046         -        CloseEventLog $hevl
  1047         -    } else {
  1048         -        DeregisterEventSource $hevl
  1049         -    }
  1050         -
  1051         -    unset eventlog_handles($hevl)
  1052         -}
  1053         -
  1054         -
  1055         -# Log an event
  1056         -proc twapi::eventlog_write {hevl id args} {
  1057         -    _eventlog_valid_handle $hevl write raise
  1058         -
  1059         -    array set opts [parseargs args {
  1060         -        {type.arg information {success error warning information auditsuccess auditfailure}}
  1061         -        {category.int 1}
  1062         -        loguser
  1063         -        params.arg
  1064         -        data.arg
  1065         -    } -nulldefault]
  1066         -
  1067         -
  1068         -    switch -exact -- $opts(type) {
  1069         -        success          {set opts(type) 0}
  1070         -        error            {set opts(type) 1}
  1071         -        warning          {set opts(type) 2}
  1072         -        information      {set opts(type) 4}
  1073         -        auditsuccess     {set opts(type) 8}
  1074         -        auditfailure     {set opts(type) 16}
  1075         -        default {error "Invalid value '$opts(type)' for option -type"}
  1076         -    }
  1077         -    
  1078         -    if {$opts(loguser)} {
  1079         -        set user [get_current_user -sid]
  1080         -    } else {
  1081         -        set user ""
  1082         -    }
  1083         -
  1084         -    ReportEvent $hevl $opts(type) $opts(category) $id \
  1085         -        $user $opts(params) $opts(data)
  1086         -}
  1087         -
  1088         -
  1089         -# Log a message 
  1090         -proc twapi::eventlog_log {message args} {
  1091         -    array set opts [parseargs args {
  1092         -        system.arg
  1093         -        source.arg
  1094         -        {type.arg information}
  1095         -        {category.int 0}
  1096         -    } -nulldefault]
  1097         -
  1098         -    set hevl [eventlog_open -write -source $opts(source) -system $opts(system)]
  1099         -
  1100         -    trap {
  1101         -        eventlog_write $hevl 1 -params [list $message] -type $opts(type) -category $opts(category)
  1102         -    } finally {
  1103         -        eventlog_close $hevl
  1104         -    }
  1105         -    return
  1106         -}
  1107         -
  1108         -proc twapi::make_logon_identity {username password domain} {
  1109         -    if {[concealed? $password]} {
  1110         -        return [list $username $domain $password]
  1111         -    } else {
  1112         -        return [list $username $domain [conceal $password]]
  1113         -    }
  1114         -}
  1115         -
  1116         -proc twapi::read_credentials {args} {
  1117         -    array set opts [parseargs args {
  1118         -        target.arg
  1119         -        winerror.int
  1120         -        username.arg
  1121         -        password.arg
  1122         -        persist.bool
  1123         -        {type.sym generic {domain 0 generic 0x40000 runas 0x80000}}
  1124         -        {forceui.bool 0 0x80}
  1125         -        {showsaveoption.bool true}
  1126         -        {expectconfirmation.bool 0 0x20000}
  1127         -    } -maxleftover 0 -nulldefault]
  1128         -
  1129         -    if {$opts(persist) && ! $opts(expectconfirmation)} {
  1130         -        badargs! "Option -expectconfirmation must be specified as true if -persist is true"
  1131         -    }
  1132         -
  1133         -    # 0x8 -> CREDUI_FLAGS_EXCLUDE_CERTIFICATES (needed for console)
  1134         -    set flags [expr {0x8 | $opts(forceui) | $opts(expectconfirmation)}]
  1135         -
  1136         -    if {$opts(persist)} {
  1137         -        if {! $opts(showsaveoption)} {
  1138         -            incr flags 0x1000;  # CREDUI_FLAGS_PERSIST
  1139         -        }
  1140         -    } else {
  1141         -        incr flags 0x2;         # CREDUI_FLAGS_DO_NOT_PERSIST
  1142         -        if {$opts(showsaveoption)} {
  1143         -            incr flags 0x40;    # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX
  1144         -        }
  1145         -    }
  1146         -
  1147         -    incr flags $opts(type)
  1148         -
  1149         -    return [CredUICmdLinePromptForCredentials $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags]
  1150         -}
  1151         -
  1152         -# Prompt for a password at the console
  1153         -proc twapi::credentials_dialog {args} {
  1154         -    array set opts [parseargs args {
  1155         -        target.arg
  1156         -        winerror.int
  1157         -        username.arg
  1158         -        password.arg
  1159         -        persist.bool
  1160         -        {type.sym generic {domain 0 generic 0x40000 runas 0x80000}}
  1161         -        {forceui.bool 0 0x80}
  1162         -        {showsaveoption.bool true}
  1163         -        {expectconfirmation.bool 0 0x20000}
  1164         -        {fillusername.bool 0 0x800}
  1165         -        {filllocaladmins.bool 0 0x4}
  1166         -        {notifyfail.bool 0 0x1}
  1167         -        {passwordonly.bool 0 0x200}
  1168         -        {requirecertificate.bool 0 0x10}
  1169         -        {requiresmartcard.bool 0 0x100}
  1170         -        {validateusername.bool 0 0x400}
  1171         -        {parent.arg NULL}
  1172         -        message.arg
  1173         -        caption.arg
  1174         -        {bitmap.arg NULL}
  1175         -    } -maxleftover 0 -nulldefault]
  1176         -
  1177         -    if {$opts(persist) && ! $opts(expectconfirmation)} {
  1178         -        badargs! "Option -willconfirm must be specified as true if -persist is true"
  1179         -    }
  1180         -
  1181         -    set flags [expr { 0x8 | $opts(forceui) | $opts(notifyfail) | $opts(expectconfirmation) | $opts(fillusername) | $opts(filllocaladmins)}]
  1182         -
  1183         -    if {$opts(persist)} {
  1184         -        if {! $opts(showsaveoption)} {
  1185         -            incr flags 0x1000;  # CREDUI_FLAGS_PERSIST
  1186         -        }
  1187         -    } else {
  1188         -        incr flags 0x2;         # CREDUI_FLAGS_DO_NOT_PERSIST
  1189         -        if {$opts(showsaveoption)} {
  1190         -            incr flags 0x40;    # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX
  1191         -        }
  1192         -    }
  1193         -
  1194         -    incr flags $opts(type)
  1195         -
  1196         -    return [CredUIPromptForCredentials [list $opts(parent) $opts(message) $opts(caption) $opts(bitmap)] $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags]
  1197         -}
  1198         -
  1199         -proc twapi::confirm_credentials {target valid} {
  1200         -    return [CredUIConfirmCredential $target $valid]
  1201         -}
  1202         -
  1203         -# Validate a handle for a mode. Always raises error if handle is invalid
  1204         -# If handle valid but not for that mode, will raise error iff $raise_error
  1205         -# is non-empty. Returns 1 if valid, 0 otherwise
  1206         -proc twapi::_eventlog_valid_handle {hevl mode {raise_error ""}} {
  1207         -    variable eventlog_handles
  1208         -    if {![info exists eventlog_handles($hevl)]} {
  1209         -        error "Invalid event log handle '$hevl'"
  1210         -    }
  1211         -
  1212         -    if {[string compare $eventlog_handles($hevl) $mode]} {
  1213         -        if {$raise_error != ""} {
  1214         -            error "Eventlog handle '$hevl' not valid for $mode"
  1215         -        }
  1216         -        return 0
  1217         -    } else {
  1218         -        return 1
  1219         -    }
  1220         -}
  1221         -
  1222         -### Common disk related
  1223         -
  1224         -# Map bit mask to list of drive letters
  1225         -proc twapi::_drivemask_to_drivelist {drivebits} {
  1226         -    set drives [list ]
  1227         -    set i 0
  1228         -    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} {
  1229         -        if {$drivebits == 0} break
  1230         -        set drivemask [expr {1 << $i}]
  1231         -        if {[expr {$drivebits & $drivemask}]} {
  1232         -            lappend drives $drive:
  1233         -            set drivebits [expr {$drivebits & ~ $drivemask}]
  1234         -        }
  1235         -        incr i
  1236         -    }
  1237         -    return $drives
  1238         -}
  1239         -
  1240         -### Type casts
  1241         -proc twapi::tclcast {type val} {
  1242         -    # Only permit these because wideInt, for example, cannot be reliably
  1243         -    # converted -> it can return an int instead.
  1244         -    set types {"" empty null int boolean double string list dict}
  1245         -    if {$type ni $types} {
  1246         -        badargs! "Bad cast to \"$type\". Must be one of: $types"
  1247         -    }
  1248         -    return [Twapi_InternalCast $type $val]
  1249         -}
  1250         -
  1251         -if {[info commands ::lmap] eq "::lmap"} {
  1252         -    proc twapi::safearray {type l} {
  1253         -        set type [dict! {
  1254         -            variant ""
  1255         -            boolean boolean
  1256         -            bool boolean
  1257         -            int  int
  1258         -            i4   int
  1259         -            double double
  1260         -            r8   double
  1261         -            string string
  1262         -            bstr string
  1263         -        } $type]
  1264         -        return [lmap val $l {tclcast $type $val}]
  1265         -    }
  1266         -} else {
  1267         -    proc twapi::safearray {type l} {
  1268         -        set type [dict! {
  1269         -            variant ""
  1270         -            boolean boolean
  1271         -            bool boolean
  1272         -            int  int
  1273         -            i4   int
  1274         -            double double
  1275         -            r8   double
  1276         -            string string
  1277         -            bstr string
  1278         -        } $type]
  1279         -        set l2 {}
  1280         -        foreach val $l {
  1281         -            lappend l2 [tclcast $type $val]
  1282         -        }
  1283         -        return $l2
  1284         -    }
  1285         -}
  1286         -
  1287         -namespace eval twapi::recordarray {}
  1288         -
  1289         -proc twapi::recordarray::size {ra} {
  1290         -    return [llength [lindex $ra 1]]
  1291         -}
  1292         -
  1293         -proc twapi::recordarray::fields {ra} {
  1294         -    return [lindex $ra 0]
  1295         -}
  1296         -
  1297         -proc twapi::recordarray::index {ra row args} {
  1298         -    set r [lindex $ra 1 $row]
  1299         -    if {[llength $r] == 0} {
  1300         -        return $r
  1301         -    }
  1302         -    ::twapi::parseargs args {
  1303         -        {format.arg list {list dict}}
  1304         -        slice.arg
  1305         -    } -setvars -maxleftover 0
  1306         -
  1307         -    set fields [lindex $ra 0]
  1308         -    if {[info exists slice]} {
  1309         -        set new_fields {}        
  1310         -        set new_r {}
  1311         -        foreach field $slice {
  1312         -            set i [twapi::enum $fields $field]
  1313         -            lappend new_r [lindex $r $i]
  1314         -            lappend new_fields [lindex $fields $i]
  1315         -        }
  1316         -        set r $new_r
  1317         -        set fields $new_fields
  1318         -    }
  1319         -
  1320         -    if {$format eq "list"} {
  1321         -        return $r
  1322         -    } else {
  1323         -        return [::twapi::twine $fields $r]
  1324         -    }
  1325         -}
  1326         -
  1327         -proc twapi::recordarray::range {ra low high} {
  1328         -    return [list [lindex $ra 0] [lrange [lindex $ra 1] $low $high]]
  1329         -}
  1330         -
  1331         -proc twapi::recordarray::column {ra field args} {
  1332         -    # TBD - time to see if a script loop would be faster
  1333         -    ::twapi::parseargs args {
  1334         -        filter.arg
  1335         -    } -nulldefault -maxleftover 0 -setvars
  1336         -    _recordarray -slice [list $field] -filter $filter -format flat $ra
  1337         -}
  1338         -
  1339         -proc twapi::recordarray::cell {ra row field} {
  1340         -    return [lindex [lindex $ra 1 $row] [twapi::enum [lindex $ra 0] $field]]
  1341         -}
  1342         -
  1343         -proc twapi::recordarray::get {ra args} {
  1344         -    ::twapi::parseargs args {
  1345         -        {format.arg list {list dict flat}}
  1346         -        key.arg
  1347         -    } -ignoreunknown -setvars
  1348         -
  1349         -    # format & key are options just to stop them flowing down to _recordarray
  1350         -    # We do not pass it in
  1351         -
  1352         -    return [_recordarray {*}$args $ra]
  1353         -}
  1354         -
  1355         -proc twapi::recordarray::getlist {ra args} {
  1356         -    # key is an option just to stop in flowing down to _recordarray
  1357         -    # We do not pass it in
  1358         -
  1359         -    if {[llength $args] == 0} {
  1360         -        return [lindex $ra 1]
  1361         -    }
  1362         -
  1363         -    ::twapi::parseargs args {
  1364         -        {format.arg list {list dict flat}}
  1365         -        key.arg
  1366         -    } -ignoreunknown -setvars
  1367         -
  1368         -
  1369         -    return [_recordarray {*}$args -format $format $ra]
  1370         -}
  1371         -
  1372         -proc twapi::recordarray::getdict {ra args} {
  1373         -    ::twapi::parseargs args {
  1374         -        {format.arg list {list dict}}
  1375         -        key.arg
  1376         -    } -ignoreunknown -setvars
  1377         -
  1378         -    if {![info exists key]} {
  1379         -        set key [lindex $ra 0 0]
  1380         -    }
  1381         -
  1382         -    # Note _recordarray has different (putting it politely) semantics
  1383         -    # of how -format and -key option are handled so the below might
  1384         -    # look a bit strange in that we pass -format as list and get
  1385         -    # back a dict
  1386         -    return [_recordarray {*}$args -format $format -key $key $ra]
  1387         -}
  1388         -
  1389         -proc twapi::recordarray::iterate {arrayvarname ra args} {
  1390         -
  1391         -    if {[llength $args] == 0} {
  1392         -        badargs! "No script supplied"
  1393         -    }
  1394         -
  1395         -    set body [lindex $args end]
  1396         -    set args [lrange $args 0 end-1]
  1397         -
  1398         -    upvar 1 $arrayvarname var
  1399         -
  1400         -    # TBD - Can this be optimized by prepending a ::foreach to body
  1401         -    # and executing that in uplevel 1 ?
  1402         -
  1403         -    foreach rec [getlist $ra {*}$args -format dict] {
  1404         -        array set var $rec
  1405         -        set code [catch {uplevel 1 $body} result]
  1406         -        switch -exact -- $code {
  1407         -            0 {}
  1408         -            1 {
  1409         -                return -errorinfo $::errorInfo -errorcode $::errorCode -code error $result
  1410         -            }
  1411         -            3 {
  1412         -                return;          # break
  1413         -            }
  1414         -            4 {
  1415         -                # continue
  1416         -            }
  1417         -            default {
  1418         -                return -code $code $result
  1419         -            }
  1420         -        }
  1421         -    }
  1422         -    return
  1423         -}
  1424         -
  1425         -proc twapi::recordarray::rename {ra renames} {
  1426         -    set new_fields {}
  1427         -    foreach field [lindex $ra 0] {
  1428         -        if {[dict exists $renames $field]} {
  1429         -            lappend new_fields [dict get $renames $field]
  1430         -        } else {
  1431         -            lappend new_fields $field
  1432         -        }
  1433         -    }
  1434         -    return [list $new_fields [lindex $ra 1]]
  1435         -}
  1436         -
  1437         -proc twapi::recordarray::concat {args} {
  1438         -    if {[llength $args] == 0} {
  1439         -        return {}
  1440         -    }
  1441         -    set args [lassign $args ra]
  1442         -    set fields [lindex $ra 0]
  1443         -    set values [list [lindex $ra 1]]
  1444         -    set width [llength $fields]
  1445         -    foreach ra $args {
  1446         -        foreach fld1 $fields fld2 [lindex $ra 0] {
  1447         -            if {$fld1 ne $fld2} {
  1448         -                twapi::badargs! "Attempt to concat record arrays with different fields ([join $fields ,] versus [join [lindex $ra 0] ,])"
  1449         -            }
  1450         -        }
  1451         -        lappend values [lindex $ra 1]
  1452         -    }
  1453         -
  1454         -    return [list $fields [::twapi::lconcat {*}$values]]
  1455         -}
  1456         -
  1457         -namespace eval twapi::recordarray {
  1458         -    namespace export cell column concat fields get getdict getlist index iterate range rename size
  1459         -    namespace ensemble create
  1460         -}
  1461         -
  1462         -# Return a suitable cstruct definition based on a C definition
  1463         -proc twapi::struct {struct_name s} {
  1464         -    variable _struct_defs
  1465         -
  1466         -    regsub -all {(/\*.* \*/){1,1}?} $s {} s
  1467         -    regsub -line -all {//.*$} $s { } s
  1468         -    set l {}
  1469         -    foreach def [split $s ";"] {
  1470         -        set def [string trim $def]
  1471         -        if {$def eq ""} continue
  1472         -        if {![regexp {^(.+[^[:alnum:]_])([[:alnum:]_]+)\s*(\[.+\])?$} $def ->  type name array]} {
  1473         -            error "Invalid definition $def"
  1474         -        }
  1475         -        
  1476         -        set child {}
  1477         -        switch -regexp -matchvar matchvar -- [string trim $type] {
  1478         -            {^char$} {set type i1}
  1479         -            {^BYTE$} -
  1480         -            {^unsigned char$} {set type ui1}
  1481         -            {^short$} {set type i2}
  1482         -            {^WORD$} -
  1483         -            {^unsigned\s+short$} {set type ui2}
  1484         -            {^BOOLEAN$} {set type bool}
  1485         -            {^LONG$} -
  1486         -            {^int$} {set type i4}
  1487         -            {^UINT$} -
  1488         -            {^ULONG$} -
  1489         -            {^DWORD$} -
  1490         -            {^unsigned\s+int$} {set type ui4}
  1491         -            {^__int64$} {set type i8}
  1492         -            {^unsigned\s+__int64$} {set type ui8}
  1493         -            {^double$} {set type r8}
  1494         -            {^LPCSTR$} -
  1495         -            {^LPSTR$} -
  1496         -            {^char\s*\*$} {set type lpstr}
  1497         -            {^LPCWSTR$} -
  1498         -            {^LPWSTR$} -
  1499         -            {^WCHAR\s*\*$} {set type lpwstr}
  1500         -            {^HANDLE$} {set type handle}
  1501         -            {^PSID$} {set type psid}
  1502         -            {^struct\s+([[:alnum:]_]+)$} {
  1503         -                # Embedded struct. It should be defined already. Calling
  1504         -                # it with no args returns its definition but doing that
  1505         -                # to retrieve the definition could be a security hole
  1506         -                # (could be passed any Tcl command!) if unwary apps
  1507         -                # pass in input from unknown sources. So we explicitly
  1508         -                # remember definitions instead.
  1509         -                set child_name [lindex $matchvar 1]
  1510         -                if {![info exists _struct_defs($child_name)]} {
  1511         -                    error "Unknown struct $child_name"
  1512         -                }
  1513         -                set child $_struct_defs($child_name)
  1514         -                set type struct
  1515         -            }
  1516         -            default {error "Unknown type $type"}
  1517         -        }
  1518         -        set count 0
  1519         -        if {$array ne ""} {
  1520         -            set count [string trim [string range $array 1 end-1]]
  1521         -            if {![string is integer -strict $count]} {
  1522         -                error "Non-integer array size"
  1523         -            }
  1524         -        }
  1525         -
  1526         -        if {[string equal -nocase $name "cbSize"] &&
  1527         -            $type in {i4 ui4} && $count == 0} {
  1528         -            set type cbsize
  1529         -        }
  1530         -
  1531         -        lappend l [list $name $type $count $child]
  1532         -    }
  1533         -
  1534         -    set proc_body [format {
  1535         -        set def %s
  1536         -        if {[llength $args] == 0} {
  1537         -            return $def
  1538         -        } else {
  1539         -            return [list $def $args]
  1540         -        }
  1541         -    } [list $l]]
  1542         -    uplevel 1 [list proc $struct_name args $proc_body]
  1543         -    set _struct_defs($struct_name) $l
  1544         -    return
  1545         -}
  1546         -

Deleted winlibs/twapi/clipboard.tcl.

     1         -#
     2         -# Copyright (c) 2004, 2008 Ashok P. Nadkarni
     3         -# All rights reserved.
     4         -#
     5         -# See the file LICENSE for license
     6         -
     7         -# Clipboard related commands
     8         -
     9         -namespace eval twapi {
    10         -}
    11         -
    12         -# Open the clipboard
    13         -# TBD - why no mechanism to pass window handle to OpenClipboard?
    14         -proc twapi::open_clipboard {} {
    15         -    OpenClipboard 0
    16         -}
    17         -
    18         -# Close the clipboard
    19         -proc twapi::close_clipboard {} {
    20         -    catch {CloseClipboard}
    21         -    return
    22         -}
    23         -
    24         -# Empty the clipboard
    25         -proc twapi::empty_clipboard {} {
    26         -    EmptyClipboard
    27         -}
    28         -
    29         -# Read data from the clipboard
    30         -proc twapi::read_clipboard {fmt} {
    31         -    # Always catch errors and close clipboard before passing exception on
    32         -    # Also ensure memory unlocked
    33         -    trap {
    34         -        set h [GetClipboardData $fmt]
    35         -        set p [GlobalLock $h]
    36         -        set data [Twapi_ReadMemory 1 $p 0 [GlobalSize $h]]
    37         -    } onerror {} {
    38         -        catch {close_clipboard}
    39         -        rethrow
    40         -    } finally {
    41         -        # If p exists, then we must have locked the handle
    42         -        if {[info exists p]} {
    43         -            GlobalUnlock $h
    44         -        }
    45         -    }
    46         -    return $data
    47         -}
    48         -
    49         -# Read text data from the clipboard
    50         -proc twapi::read_clipboard_text {args} {
    51         -    array set opts [parseargs args {
    52         -        {raw.bool 0}
    53         -    }]
    54         -
    55         -    trap {
    56         -        set h [GetClipboardData 13];    # 13 -> Unicode
    57         -        set p [GlobalLock $h]
    58         -        # Read data discarding terminating null
    59         -        set data [Twapi_ReadMemory 3 $p 0 [GlobalSize $h] 1]
    60         -        if {! $opts(raw)} {
    61         -            set data [string map {"\r\n" "\n"} $data]
    62         -        }
    63         -    } onerror {} {
    64         -        catch {close_clipboard}
    65         -        rethrow
    66         -    } finally {
    67         -        if {[info exists p]} {
    68         -            GlobalUnlock $h
    69         -        }
    70         -    }
    71         -
    72         -    return $data
    73         -}
    74         -
    75         -# Write data to the clipboard
    76         -proc twapi::write_clipboard {fmt data} {
    77         -    # Always catch errors and close
    78         -    # clipboard before passing exception on
    79         -    trap {
    80         -        # For byte arrays, string length does return correct size
    81         -        # (DO NOT USE string bytelength - see Tcl docs!)
    82         -        set len [string length $data]
    83         -
    84         -        # Allocate global memory
    85         -        set mem_h [GlobalAlloc 2 $len]
    86         -        set mem_p [GlobalLock $mem_h]
    87         -
    88         -        Twapi_WriteMemory 1 $mem_p 0 $len $data
    89         -
    90         -        # The rest of this code just to ensure we do not free
    91         -        # memory beyond this point irrespective of error/success
    92         -        set h $mem_h
    93         -        unset mem_p mem_h
    94         -        GlobalUnlock $h
    95         -        SetClipboardData $fmt $h
    96         -    } onerror {} {
    97         -        catch {close_clipboard}
    98         -        rethrow
    99         -    } finally {
   100         -        if {[info exists mem_p]} {
   101         -            GlobalUnlock $mem_h
   102         -        }
   103         -        if {[info exists mem_h]} {
   104         -            GlobalFree $mem_h
   105         -        }
   106         -    }
   107         -    return
   108         -}
   109         -
   110         -# Write text to the clipboard
   111         -proc twapi::write_clipboard_text {data args} {
   112         -    array set opts [parseargs args {
   113         -        {raw.bool 0}
   114         -    }]
   115         -
   116         -    # Always catch errors and close
   117         -    # clipboard before passing exception on
   118         -    trap {
   119         -        # Convert \n to \r\n leaving existing \r\n alone
   120         -        if {! $opts(raw)} {
   121         -            set data [regsub -all {(^|[^\r])\n} $data[set data ""] \\1\r\n]
   122         -        }
   123         -                  
   124         -        set mem_size [expr {2*(1+[string length $data])}]
   125         -
   126         -        # Allocate global memory
   127         -        set mem_h [GlobalAlloc 2 $mem_size]
   128         -        set mem_p [GlobalLock $mem_h]
   129         -
   130         -        # 3 -> write memory as Unicode
   131         -        Twapi_WriteMemory 3 $mem_p 0 $mem_size $data
   132         -
   133         -        # The rest of this code just to ensure we do not free
   134         -        # memory beyond this point irrespective of error/success
   135         -        set h $mem_h
   136         -        unset mem_h mem_p
   137         -        GlobalUnlock $h
   138         -        SetClipboardData 13 $h;         # 13 -> Unicode format
   139         -    } onerror {} {
   140         -        catch {close_clipboard}
   141         -        rethrow
   142         -    } finally {
   143         -        if {[info exists mem_p]} {
   144         -            GlobalUnlock $mem_h
   145         -        }
   146         -        if {[info exists mem_h]} {
   147         -            GlobalFree $mem_h
   148         -        }
   149         -    }
   150         -    return
   151         -}
   152         -
   153         -# Get current clipboard formats
   154         -proc twapi::get_clipboard_formats {} {
   155         -    return [Twapi_EnumClipboardFormats]
   156         -}
   157         -
   158         -# Get registered clipboard format name. Clipboard does not have to be open
   159         -proc twapi::get_registered_clipboard_format_name {fmt} {
   160         -    return [GetClipboardFormatName $fmt]
   161         -}
   162         -
   163         -# Register a clipboard format
   164         -proc twapi::register_clipboard_format {fmt_name} {
   165         -    RegisterClipboardFormat $fmt_name
   166         -}
   167         -
   168         -# Returns 1/0 depending on whether a format is on the clipboard. Clipboard
   169         -# does not have to be open
   170         -proc twapi::clipboard_format_available {fmt} {
   171         -    return [IsClipboardFormatAvailable $fmt]
   172         -}
   173         -
   174         -
   175         -
   176         -# Start monitoring of the clipboard
   177         -proc twapi::_clipboard_handler {} {
   178         -    variable _clipboard_monitors
   179         -
   180         -    if {![info exists _clipboard_monitors] ||
   181         -        [llength $_clipboard_monitors] == 0} {
   182         -        return; # Not an error, could have deleted while already queued
   183         -    }
   184         -
   185         -    foreach {id script} $_clipboard_monitors {
   186         -        set code [catch {uplevel #0 $script} msg]
   187         -        if {$code == 1} {
   188         -            # Error - put in background but we do not abort
   189         -            after 0 [list error $msg $::errorInfo $::errorCode]
   190         -        }
   191         -    }
   192         -    return
   193         -}
   194         -
   195         -proc twapi::start_clipboard_monitor {script} {
   196         -    variable _clipboard_monitors
   197         -
   198         -    set id "clip#[TwapiId]"
   199         -    if {![info exists _clipboard_monitors] ||
   200         -        [llength $_clipboard_monitors] == 0} {
   201         -        # No clipboard monitoring in progress. Start it
   202         -        Twapi_ClipboardMonitorStart
   203         -    }
   204         -
   205         -    lappend _clipboard_monitors $id $script
   206         -    return $id
   207         -}
   208         -
   209         -
   210         -
   211         -# Stop monitoring of the clipboard
   212         -proc twapi::stop_clipboard_monitor {clipid} {
   213         -    variable _clipboard_monitors
   214         -
   215         -    if {![info exists _clipboard_monitors]} {
   216         -        return;                 # Should we raise an error instead?
   217         -    }
   218         -
   219         -    set new_monitors {}
   220         -    foreach {id script} $_clipboard_monitors {
   221         -        if {$id ne $clipid} {
   222         -            lappend new_monitors $id $script
   223         -        }
   224         -    }
   225         -
   226         -    set _clipboard_monitors $new_monitors
   227         -    if {[llength $_clipboard_monitors] == 0} {
   228         -        Twapi_ClipboardMonitorStop
   229         -    }
   230         -}

Deleted winlibs/twapi/com.tcl.

     1         -#
     2         -# Copyright (c) 2006-2014 Ashok P. Nadkarni
     3         -# All rights reserved.
     4         -#
     5         -# See the file LICENSE for license
     6         -
     7         -# TBD - tests  comobj? works with derived classes of Automation
     8         -# TBD - document and test -iterate -cleanup option
     9         -
    10         -# TBD - object identity comparison 
    11         -#   - see http://blogs.msdn.com/ericlippert/archive/2005/04/26/412199.aspx
    12         -# TBD - we seem to resolve UDT's every time a COM method is actually invoked.
    13         -# Optimize by doing it when prototype is stored or only the first time it
    14         -# is called.
    15         -# TBD - optimize by caching UDT's within a type library when the library
    16         -# is read.
    17         -
    18         -namespace eval twapi {
    19         -    # Maps TYPEKIND data values to symbols
    20         -    variable _typekind_map
    21         -    array set _typekind_map {
    22         -        0 enum
    23         -        1 record
    24         -        2 module
    25         -        3 interface
    26         -        4 dispatch
    27         -        5 coclass
    28         -        6 alias
    29         -        7 union
    30         -    }
    31         -
    32         -    # Cache of Interface names - IID mappings
    33         -    variable _name_to_iid_cache
    34         -    array set _name_to_iid_cache {
    35         -        iunknown  {{00000000-0000-0000-C000-000000000046}}
    36         -        idispatch {{00020400-0000-0000-C000-000000000046}}
    37         -        idispatchex {{A6EF9860-C720-11D0-9337-00A0C90DCAA9}}
    38         -        itypeinfo {{00020401-0000-0000-C000-000000000046}}
    39         -        itypecomp {{00020403-0000-0000-C000-000000000046}}
    40         -        ienumvariant {{00020404-0000-0000-C000-000000000046}}
    41         -        iprovideclassinfo {{B196B283-BAB4-101A-B69C-00AA00341D07}}
    42         -
    43         -        ipersist  {{0000010c-0000-0000-C000-000000000046}}
    44         -        ipersistfile {{0000010b-0000-0000-C000-000000000046}}
    45         -
    46         -        iprovidetaskpage {{4086658a-cbbb-11cf-b604-00c04fd8d565}}
    47         -        itasktrigger {{148BD52B-A2AB-11CE-B11F-00AA00530503}}
    48         -        ischeduleworkitem {{a6b952f0-a4b1-11d0-997d-00aa006887ec}}
    49         -        itask {{148BD524-A2AB-11CE-B11F-00AA00530503}}
    50         -        ienumworkitems {{148BD528-A2AB-11CE-B11F-00AA00530503}}
    51         -        itaskscheduler {{148BD527-A2AB-11CE-B11F-00AA00530503}}
    52         -        imofcompiler {{6daf974e-2e37-11d2-aec9-00c04fb68820}}
    53         -    }
    54         -}
    55         -
    56         -proc twapi::IUnknown_QueryInterface {ifc iid} {
    57         -    set iidname void
    58         -    catch {set iidname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]}
    59         -    return [Twapi_IUnknown_QueryInterface $ifc $iid $iidname]
    60         -}
    61         -
    62         -proc twapi::CoGetObject {name bindopts iid} {
    63         -    set iidname void
    64         -    catch {set iidname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]}
    65         -    return [Twapi_CoGetObject $name $bindopts $iid $iidname]
    66         -}
    67         -
    68         -proc twapi::progid_to_clsid {progid} { return [CLSIDFromProgID $progid] }
    69         -proc twapi::clsid_to_progid {progid} { return [ProgIDFromCLSID $progid] }
    70         -
    71         -proc twapi::com_security_blanket {args} {
    72         -    # mutualauth.bool - docs for EOLE_AUTHENTICATION_CAPABILITIES. Learning
    73         -    # DCOM says it is only for CoInitializeSecurity. Either way, 
    74         -    # that option is not applicable here
    75         -    parseargs args {
    76         -        {authenticationservice.arg default}
    77         -        serverprincipal.arg
    78         -        {authenticationlevel.arg default}
    79         -        {impersonationlevel.arg default}
    80         -        credentials.arg
    81         -        cloaking.arg
    82         -    } -maxleftover 0 -setvars
    83         -
    84         -    set authenticationservice [_com_name_to_authsvc $authenticationservice]
    85         -    set authenticationlevel [_com_name_to_authlevel $authenticationlevel]
    86         -    set impersonationlevel [_com_name_to_impersonation $impersonationlevel]
    87         -
    88         -    if {![info exists cloaking]} {
    89         -        set eoac 0x800;         # EOAC_DEFAULT
    90         -    } else {
    91         -        set eoac [dict! {none 0 static 0x20 dynamic 0x40} $cloaking]
    92         -    }
    93         -
    94         -    if {[info exists credentials]} {
    95         -        # Credentials specified. Empty list -> NULL, ie use thread token
    96         -        set creds_tag 1
    97         -    } else {
    98         -        # Credentials not to be changed
    99         -        set creds_tag 0
   100         -        set credentials {};     # Ignored
   101         -    }
   102         -
   103         -    if {[info exists serverprincipal]} {
   104         -        if {$serverprincipal eq ""} {
   105         -            set serverprincipaltag 0; # Default based on com_initialize_security
   106         -        } else {
   107         -            set serverprincipaltag 2
   108         -        }
   109         -    } else {
   110         -        set serverprincipaltag 1; # Unchanged server principal
   111         -        set serverprincipal ""
   112         -    }
   113         -
   114         -    return [list $authenticationservice 0 $serverprincipaltag $serverprincipal $authenticationlevel $impersonationlevel $creds_tag $credentials $eoac]
   115         -}
   116         -
   117         -# TBD - document
   118         -proc twapi::com_query_client_blanket {} {
   119         -    lassign [CoQueryClientBlanket] authn authz server authlevel implevel client capabilities
   120         -    if {$capabilities & 0x20} {
   121         -        # EOAC_STATIC_CLOAKING
   122         -        set cloaking static
   123         -    } elseif {$capabilities & 0x40} {
   124         -        set cloaking dynamic
   125         -    } else {
   126         -        set cloaking none
   127         -    }
   128         -
   129         -    # Note there is no implevel set as CoQueryClientBlanket does
   130         -    # not return that information and implevel is a dummy value
   131         -    return [list \
   132         -                -authenticationservice [_com_authsvc_to_name $authn] \
   133         -                -authorizationservice [dict* {0 none 1 name 2 dce} $authz] \
   134         -                -serverprincipal $server \
   135         -                -authenticationlevel [_com_authlevel_to_name $authlevel] \
   136         -                -clientprincipal $client \
   137         -                -cloaking $cloaking \
   138         -               ]
   139         -}
   140         -
   141         -# TBD - document
   142         -proc twapi::com_query_proxy_blanket {ifc} {
   143         -    lassign [CoQueryProxyBlanket [lindex $args 0]] authn authz server authlevel implevel client capabilities
   144         -    if {$capabilities & 0x20} {
   145         -        # EOAC_STATIC_CLOAKING
   146         -        set cloaking static
   147         -    } elseif {$capabilities & 0x40} {
   148         -        set cloaking dynamic
   149         -    } else {
   150         -        set cloaking none
   151         -    }
   152         -
   153         -    return [list \
   154         -                -authenticationservice [_com_authsvc_to_name $authn] \
   155         -                -authorizationservice [dict* {0 none 1 name 2 dce} $authz] \
   156         -                -serverprincipal $server \
   157         -                -authenticationlevel [_com_authlevel_to_name $authlevel] \
   158         -                -impersonationlevel [_com_impersonation_to_name $implevel] \
   159         -                -clientprincipal $client \
   160         -                -cloaking $cloaking \
   161         -               ]
   162         -            
   163         -}
   164         -
   165         -# TBD - document
   166         -proc twapi::com_initialize_security {args} {
   167         -    # TBD - mutualauth?
   168         -    # TBD - securerefs?
   169         -    parseargs args {
   170         -        {authenticationlevel.arg default}
   171         -        {impersonationlevel.arg impersonate}
   172         -        {cloaking.sym none {none 0 static 0x20 dynamic 0x40}}
   173         -        secd.arg
   174         -        appid.arg
   175         -        authenticationservices.arg
   176         -    } -maxleftover 0 -setvars
   177         -    
   178         -    if {[info exists secd] && [info exists appid]} {
   179         -        badargs! "Only one of -secd and -appid can be specified."
   180         -    }
   181         -
   182         -    set impersonationlevel [_com_name_to_impersonation $impersonationlevel]
   183         -    set authenticationlevel [_com_name_to_authlevel $authenticationlevel]
   184         -
   185         -    set eoac $cloaking
   186         -    if {[info exists appid]} {
   187         -        incr eoac 8;     # 8 -> EOAC_APPID
   188         -        set secarg $appid
   189         -    } else {
   190         -        if {[info exists secd]} {
   191         -            set secarg $secd
   192         -        } else {
   193         -            set secarg {}
   194         -        }
   195         -    }
   196         -
   197         -    set authlist {}
   198         -    if {[info exists authenticationservices]} {
   199         -        foreach authsvc $authenticationservices {
   200         -            lappend authlist [list [_com_name_to_authsvc [lindex $authsvc 0]] 0 [lindex $authsvc 1]]
   201         -        }
   202         -    }
   203         -
   204         -    CoInitializeSecurity $secarg "" "" $authenticationlevel $impersonationlevel $authlist $eoac ""
   205         -}
   206         -
   207         -interp alias {} twapi::com_make_credentials {} twapi::make_logon_identity
   208         -
   209         -# TBD - document
   210         -proc twapi::com_create_instance {clsid args} {
   211         -    array set opts [parseargs args {
   212         -        {model.arg any}
   213         -        download.bool
   214         -        {disablelog.bool false}
   215         -        enableaaa.bool
   216         -        {nocustommarshal.bool false 0x1000}
   217         -        {interface.arg IUnknown}
   218         -        {authenticationservice.arg none}
   219         -        {impersonationlevel.arg impersonate}
   220         -        {credentials.arg {}}
   221         -        {serverprincipal.arg {}}
   222         -        {authenticationlevel.arg default}
   223         -        {mutualauth.bool 0 0x1}
   224         -        securityblanket.arg
   225         -        system.arg
   226         -        raw
   227         -    } -maxleftover 0]
   228         -
   229         -    set opts(authenticationservice) [_com_name_to_authsvc $opts(authenticationservice)]
   230         -    set opts(authenticationlevel) [_com_name_to_authlevel $opts(authenticationlevel)]
   231         -    set opts(impersonationlevel) [_com_name_to_impersonation $opts(impersonationlevel)]
   232         -
   233         -    # CLSCTX_NO_CUSTOM_MARSHAL ?
   234         -    set flags $opts(nocustommarshal)
   235         -
   236         -    set model 0
   237         -    if {[info exists opts(model)]} {
   238         -        foreach m $opts(model) {
   239         -            switch -exact -- $m {
   240         -                any           {setbits model 23}
   241         -                inprocserver  {setbits model 1}
   242         -                inprochandler {setbits model 2}
   243         -                localserver   {setbits model 4}
   244         -                remoteserver  {setbits model 16}
   245         -            }
   246         -        }
   247         -    }
   248         -
   249         -    setbits flags $model
   250         -
   251         -    if {[info exists opts(download)]} {
   252         -        if {$opts(download)} {
   253         -            setbits flags 0x2000;       # CLSCTX_ENABLE_CODE_DOWNLOAD
   254         -        } else {
   255         -            setbits flags 0x400;       # CLSCTX_NO_CODE_DOWNLOAD
   256         -        }
   257         -    }
   258         -
   259         -    if {$opts(disablelog)} {
   260         -        setbits flags 0x4000;           # CLSCTX_NO_FAILURE_LOG
   261         -    }
   262         -
   263         -    if {[info exists opts(enableaaa)]} {
   264         -        if {$opts(enableaaa)} {
   265         -            setbits flags 0x10000;       # CLSCTX_ENABLE_AAA
   266         -        } else {
   267         -            setbits flags 0x8000;       # CLSCTX_DISABLE_AAA
   268         -        }
   269         -    }
   270         -
   271         -    if {[info exists opts(system)]} {
   272         -        set coserverinfo [list 0 $opts(system) \
   273         -                              [list $opts(authenticationservice) \
   274         -                                   0 \
   275         -                                   $opts(serverprincipal) \
   276         -                                   $opts(authenticationlevel) \
   277         -                                   $opts(impersonationlevel) \
   278         -                                   $opts(credentials) \
   279         -                                   $opts(mutualauth) \
   280         -                                   ] \
   281         -                              0]
   282         -        set activation_blanket \
   283         -            [com_security_blanket \
   284         -                 -authenticationservice $opts(authenticationservice) \
   285         -                 -serverprincipal $opts(serverprincipal) \
   286         -                 -authenticationlevel $opts(authenticationlevel) \
   287         -                 -impersonationlevel $opts(impersonationlevel) \
   288         -                 -credentials $opts(credentials)]
   289         -    } else {
   290         -        set coserverinfo {}
   291         -    }
   292         -
   293         -    # If remote, set the specified security blanket on the proxy. Note
   294         -    # that the blanket settings passed to CoCreateInstanceEx are used
   295         -    # only for activation and do NOT get passed down to method calls
   296         -    # If a remote component is activated with specific identity, we
   297         -    # assume method calls require the same security settings.
   298         -
   299         -    if {([info exists activation_blanket] || [llength $opts(credentials)]) &&
   300         -        ![info exists opts(securityblanket)]} {
   301         -        if {[info exists activation_blanket]} {
   302         -            set opts(securityblanket) $activation_blanket
   303         -        } else {
   304         -            set opts(securityblanket) [com_security_blanket -credentials $opts(credentials)]
   305         -        }
   306         -    }
   307         -
   308         -    lassign [_resolve_iid $opts(interface)] iid iid_name
   309         -
   310         -    # TBD - is all this OleRun still necessary or is there a check we can make
   311         -    # before going down that path ?
   312         -    # Microsoft Office (and maybe others) have some, uhhm, quirks.
   313         -    # If they are loaded as inproc, all calls to retrieve an interface other 
   314         -    # than IUnknown fails. We have to get the IUnknown interface,
   315         -    # call OleRun and then retrieve the desired interface.
   316         -    # This does not happen if the localserver model was requested.
   317         -    # We could check for a specific error code but no guarantee that
   318         -    # the error is same in all versions so we catch and retry on all errors.
   319         -    # 3rd element of each sublist is status. Non-0 -> Failure code
   320         -    if {[catch {set ifcs [CoCreateInstanceEx $clsid NULL $flags $coserverinfo [list $iid]]}] || [lindex $ifcs 0 2] != 0} {
   321         -        # Try through IUnknown
   322         -        set ifcs [CoCreateInstanceEx $clsid NULL $flags $coserverinfo [list [_iid_iunknown]]]
   323         -
   324         -        if {[lindex $ifcs 0 2] != 0} {
   325         -            win32_error [lindex $ifcs 0 2]
   326         -        }
   327         -        set iunk [lindex $ifcs 0 1]
   328         -
   329         -        # Need to set security blanket if specified before invoking any method
   330         -        # else will get access denied
   331         -        if {[info exists opts(securityblanket)]} {
   332         -            trap {
   333         -                CoSetProxyBlanket $iunk {*}$opts(securityblanket)
   334         -            } onerror {} {
   335         -                IUnknown_Release $iunk
   336         -                rethrow
   337         -            }
   338         -        }
   339         -
   340         -        trap {
   341         -            # Wait for it to run, then get desired interface from it
   342         -            twapi::OleRun $iunk
   343         -            set ifc [Twapi_IUnknown_QueryInterface $iunk $iid $iid_name]
   344         -        } finally {
   345         -            IUnknown_Release $iunk
   346         -        }
   347         -    } else {
   348         -        set ifc [lindex $ifcs 0 1]
   349         -    }
   350         -
   351         -    # All interfaces are returned typed as IUnknown by the C level
   352         -    # even though they are actually the requested type.
   353         -    set ifc [cast_handle $ifc $iid_name]
   354         -
   355         -    if {[info exists activation_blanket]} {
   356         -        # In order for servers to release objects properly, the IUnknown 
   357         -        # interface must have the same security settings as were used in 
   358         -        # the object creation
   359         -        _com_set_iunknown_proxy $ifc $activation_blanket
   360         -    }
   361         -
   362         -    if {$opts(raw)} {
   363         -        if {[info exists opts(securityblanket)]} {
   364         -            trap {
   365         -                CoSetProxyBlanket $ifc {*}$opts(securityblanket)
   366         -            } onerror {} {
   367         -                IUnknown_Release $ifc
   368         -                rethrow
   369         -            }
   370         -        }
   371         -        return $ifc
   372         -    } else {
   373         -        set proxy [make_interface_proxy $ifc]
   374         -        if {[info exists opts(securityblanket)]} {
   375         -            trap {
   376         -                $proxy @SetSecurityBlanket $opts(securityblanket)
   377         -            } onerror {} {
   378         -                catch {$proxy Release}
   379         -                rethrow
   380         -            }
   381         -        }
   382         -        return $proxy
   383         -    }
   384         -}
   385         -
   386         -
   387         -proc twapi::comobj_idispatch {ifc {addref 0} {objclsid ""} {lcid 0}} {
   388         -    if {[pointer_null? $ifc]} {
   389         -        return ::twapi::comobj_null
   390         -    }
   391         -
   392         -    if {[pointer? $ifc IDispatch]} {
   393         -        if {$addref} { IUnknown_AddRef $ifc }
   394         -        set proxyobj [IDispatchProxy new $ifc $objclsid]
   395         -    } elseif {[pointer? $ifc IDispatchEx]} {
   396         -        if {$addref} { IUnknown_AddRef $ifc }
   397         -        set proxyobj [IDispatchExProxy new $ifc $objclsid]
   398         -    } else {
   399         -        error "'$ifc' does not reference an IDispatch interface"
   400         -    }
   401         -
   402         -    return [Automation new $proxyobj $lcid]
   403         -}
   404         -
   405         -#
   406         -# Create an object command for a COM object from a name
   407         -proc twapi::comobj_object {path args} {
   408         -    array set opts [parseargs args {
   409         -        progid.arg
   410         -        {interface.arg IDispatch {IDispatch IDispatchEx}}
   411         -        {lcid.int 0}
   412         -    } -maxleftover 0]
   413         -
   414         -    set clsid ""
   415         -    if {[info exists opts(progid)]} {
   416         -        # TBD - document once we have a test case for this
   417         -        # Specify which app to use to open the file.
   418         -        # See "Mapping Visual Basic to Automation" in SDK help
   419         -        set clsid [_convert_to_clsid $opts(progid)]
   420         -        set ipersistfile [com_create_instance $clsid -interface IPersistFile]
   421         -        trap {
   422         -            IPersistFile_Load $ipersistfile $path 0
   423         -            set idisp [Twapi_IUnknown_QueryInterface $ipersistfile [_iid_idispatch] IDispatch]
   424         -        } finally {
   425         -            IUnknown_Release $ipersistfile
   426         -        }
   427         -    } else {
   428         -        # TBD - can we get the CLSID for this case
   429         -        set idisp [::twapi::Twapi_CoGetObject $path {} [name_to_iid $opts(interface)] $opts(interface)]
   430         -    }
   431         -
   432         -    return [comobj_idispatch $idisp 0 $clsid $opts(lcid)]
   433         -}
   434         -
   435         -#
   436         -# Create a object command for a COM object IDispatch interface
   437         -# comid is either a CLSID or a PROGID
   438         -proc twapi::comobj {comid args} {
   439         -    array set opts [parseargs args {
   440         -        {interface.arg IDispatch {IDispatch IDispatchEx}}
   441         -        active
   442         -        {lcid.int 0}
   443         -    } -ignoreunknown]
   444         -    set clsid [_convert_to_clsid $comid]
   445         -    if {$opts(active)} {
   446         -        set iunk [GetActiveObject $clsid]
   447         -        twapi::trap {
   448         -            # TBD - do we need to deal with security blanket here? How do
   449         -            # know what blanket is to be used on an already active object?
   450         -            # Get the IDispatch interface
   451         -            set idisp [IUnknown_QueryInterface $iunk {{00020400-0000-0000-C000-000000000046}}]
   452         -            return [comobj_idispatch $idisp 0 $clsid $opts(lcid)]
   453         -        } finally {
   454         -            IUnknown_Release $iunk
   455         -        }
   456         -    } else {
   457         -        set proxy [com_create_instance $clsid -interface $opts(interface) {*}$args]
   458         -        $proxy @SetCLSID $clsid
   459         -        return [Automation new $proxy $opts(lcid)]
   460         -    }
   461         -}
   462         -
   463         -proc twapi::comobj_destroy args {
   464         -    foreach arg $args {
   465         -        catch {$arg -destroy}
   466         -    }
   467         -}
   468         -
   469         -# Return an interface to a typelib
   470         -# TBD - document
   471         -proc twapi::ITypeLibProxy_from_path {path args} {
   472         -    array set opts [parseargs args {
   473         -        {registration.arg none {none register default}}
   474         -    } -maxleftover 0]
   475         -
   476         -    return [make_interface_proxy [LoadTypeLibEx $path [kl_get {default 0 register 1 none 2} $opts(registration) $opts(registration)]]]
   477         -}
   478         -
   479         -#
   480         -# Return an interface to a typelib from the registry
   481         -# TBD - document
   482         -proc twapi::ITypeLibProxy_from_guid {uuid major minor args} {
   483         -    array set opts [parseargs args {
   484         -        lcid.int
   485         -    } -maxleftover 0 -nulldefault]
   486         -    
   487         -    return [make_interface_proxy [LoadRegTypeLib $uuid $major $minor $opts(lcid)]]
   488         -}
   489         -
   490         -#
   491         -# Unregister a typelib
   492         -proc twapi::unregister_typelib {uuid major minor args} {
   493         -    array set opts [parseargs args {
   494         -        lcid.int
   495         -    } -maxleftover 0 -nulldefault]
   496         -
   497         -    UnRegisterTypeLib $uuid $major $minor $opts(lcid) 1
   498         -}
   499         -
   500         -#
   501         -# Returns the path to the typelib based on a guid
   502         -proc twapi::get_typelib_path_from_guid {guid major minor args} {
   503         -    array set opts [parseargs args {
   504         -        lcid.int
   505         -    } -maxleftover 0 -nulldefault]
   506         -
   507         -
   508         -    set path [variant_value [QueryPathOfRegTypeLib $guid $major $minor $opts(lcid)] 0 0 $opts(lcid)]
   509         -    # At least some versions have a bug in that there is an extra \0
   510         -    # at the end.
   511         -    if {[string equal [string index $path end] \0]} {
   512         -        set path [string range $path 0 end-1]
   513         -    }
   514         -    return $path
   515         -}
   516         -
   517         -#
   518         -# Map interface name to IID
   519         -proc twapi::name_to_iid {iname} {
   520         -    set iname [string tolower $iname]
   521         -
   522         -    if {[info exists ::twapi::_name_to_iid_cache($iname)]} {
   523         -        return $::twapi::_name_to_iid_cache($iname)
   524         -    }
   525         -
   526         -    # Look up the registry
   527         -    set iids {}
   528         -    foreach iid [registry keys HKEY_CLASSES_ROOT\\Interface] {
   529         -        if {![catch {
   530         -            set val [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]
   531         -        }]} {
   532         -            if {[string equal -nocase $iname $val]} {
   533         -                lappend iids $iid
   534         -            }
   535         -        }
   536         -    }
   537         -
   538         -    if {[llength $iids] == 1} {
   539         -        return [set ::twapi::_name_to_iid_cache($iname) [lindex $iids 0]]
   540         -    } elseif {[llength $iids]} {
   541         -        error "Multiple interfaces found matching name $iname: [join $iids ,]"
   542         -    } else {
   543         -        return [set ::twapi::_name_to_iid_cache($iname) ""]
   544         -    }
   545         -}
   546         -
   547         -
   548         -#
   549         -# Map interface IID to name
   550         -proc twapi::iid_to_name {iid} {
   551         -    set iname ""
   552         -    catch {set iname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]}
   553         -    return $iname
   554         -}
   555         -
   556         -#
   557         -# Convert a variant time to a time list
   558         -proc twapi::variant_time_to_timelist {double} {
   559         -    return [VariantTimeToSystemTime $double]
   560         -}
   561         -
   562         -#
   563         -# Convert a time list time to a variant time
   564         -proc twapi::timelist_to_variant_time {timelist} {
   565         -    return [SystemTimeToVariantTime $timelist]
   566         -}
   567         -
   568         -
   569         -proc twapi::typelib_print {path args} {
   570         -    array set opts [parseargs args {
   571         -        type.arg
   572         -        name.arg
   573         -        output.arg
   574         -    } -maxleftover 0 -nulldefault]
   575         -
   576         -    
   577         -    if {$opts(output) ne ""} {
   578         -        if {[file exists $opts(output)]} {
   579         -            error "File $opts(output) already exists."
   580         -        }
   581         -        set outfd [open $opts(output) a]
   582         -    } else {
   583         -        set outfd stdout
   584         -    }
   585         -
   586         -    trap {
   587         -        set tl [ITypeLibProxy_from_path $path -registration none]
   588         -        puts $outfd [$tl @Text -type $opts(type) -name $opts(name)]
   589         -    } finally {
   590         -        if {[info exists tl]} {
   591         -            $tl Release
   592         -        }
   593         -        if {$outfd ne "stdout"} {
   594         -            close $outfd
   595         -        }
   596         -    }        
   597         -
   598         -    return
   599         -}
   600         -
   601         -proc twapi::generate_code_from_typelib {path args} {
   602         -    array set opts [parseargs args {
   603         -        output.arg
   604         -    } -ignoreunknown]
   605         -
   606         -    if {[info exists opts(output)]} {
   607         -        if {$opts(output) ne "stdout"} {
   608         -            if {[file exists $opts(output)]} {
   609         -                error "File $opts(output) already exists."
   610         -            }
   611         -            set outfd [open $opts(output) a]
   612         -        } else {
   613         -            set outfd stdout
   614         -        }
   615         -    }
   616         -
   617         -    trap {
   618         -        set tl [ITypeLibProxy_from_path $path -registration none]
   619         -        set code [$tl @GenerateCode {*}$args]
   620         -        if {[info exists outfd]} {
   621         -            puts $outfd "package require twapi_com"
   622         -            puts $outfd $code
   623         -            return
   624         -        } else {
   625         -            return $code
   626         -        }
   627         -    } finally {
   628         -        if {[info exists tl]} {
   629         -            $tl Release
   630         -        }
   631         -        if {[info exists outfd] && $outfd ne "stdout"} {
   632         -            close $outfd
   633         -        }
   634         -    }        
   635         -}
   636         -
   637         -
   638         -
   639         -
   640         -proc twapi::_interface_text {ti} {
   641         -    # ti must be TypeInfo for an interface or module (or enum?) - TBD
   642         -    set desc ""
   643         -    array set attrs [$ti @GetTypeAttr -all]
   644         -    set desc "Functions:\n"
   645         -    for {set j 0} {$j < $attrs(-fncount)} {incr j} {
   646         -        array set funcdata [$ti @GetFuncDesc $j -all]
   647         -        if {$funcdata(-funckind) eq "dispatch"} {
   648         -            set funckind "(dispid $funcdata(-memid))"
   649         -        } else {
   650         -            set funckind "(vtable $funcdata(-vtbloffset))"
   651         -        }
   652         -        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"
   653         -    }
   654         -    append desc "Variables:\n"
   655         -    for {set j 0} {$j < $attrs(-varcount)} {incr j} {
   656         -        array set vardata [$ti @GetVarDesc $j -all]
   657         -        set vardesc "($vardata(-memid)) $vardata(-varkind) [::twapi::_flatten_com_type [::twapi::_resolve_com_type_text $ti $vardata(-datatype)]] $vardata(-name)"
   658         -        if {$attrs(-typekind) eq "enum" || $vardata(-varkind) eq "const"} {
   659         -            append vardesc " = $vardata(-value)"
   660         -        } else {
   661         -            append vardesc " (offset $vardata(-value))"
   662         -        }
   663         -        append desc "\t$vardesc\n"
   664         -    }
   665         -    return $desc
   666         -}
   667         -
   668         -#
   669         -# Print methods in an interface, including inherited names
   670         -proc twapi::dispatch_print {di args} {
   671         -    array set opts [parseargs args {
   672         -        output.arg
   673         -    } -maxleftover 0 -nulldefault]
   674         -
   675         -    if {$opts(output) ne ""} {
   676         -        if {[file exists $opts(output)]} {
   677         -            error "File $opts(output) already exists."
   678         -        }
   679         -        set outfd [open $opts(output) a]
   680         -    } else {
   681         -        set outfd stdout
   682         -    }
   683         -
   684         -    trap {
   685         -        set ti [$di @GetTypeInfo]
   686         -        twapi::_dispatch_print_helper $ti $outfd
   687         -    } finally {
   688         -        if {[info exists ti]} {
   689         -            $ti Release
   690         -        }
   691         -        if {$outfd ne "stdout"} {
   692         -            close $outfd
   693         -        }
   694         -    }
   695         -
   696         -    return
   697         -}
   698         -
   699         -proc twapi::_dispatch_print_helper {ti outfd {names_already_done ""}} {
   700         -    set name [$ti @GetName]
   701         -    if {$name in $names_already_done} {
   702         -        # Already printed this
   703         -        return $names_already_done
   704         -    }
   705         -    lappend names_already_done $name
   706         -
   707         -    # Check for dual interfaces - we want to print both vtable and disp versions
   708         -    set tilist [list $ti]
   709         -    if {![catch {set ti2 [$ti @GetRefTypeInfoFromIndex $ti -1]}]} {
   710         -        lappend tilist $ti2
   711         -    }
   712         -
   713         -    trap {
   714         -        foreach tifc $tilist {
   715         -            puts $outfd $name
   716         -            puts $outfd [_interface_text $tifc]
   717         -        }
   718         -    } finally {
   719         -        if {[info exists ti2]} {
   720         -            $ti2 Release
   721         -        }
   722         -    }
   723         -
   724         -    # Now get any referenced typeinfos and print them
   725         -    array set tiattrs [$ti GetTypeAttr]
   726         -    for {set j 0} {$j < $tiattrs(cImplTypes)} {incr j} {
   727         -        set ti2 [$ti @GetRefTypeInfoFromIndex $j]
   728         -        trap {
   729         -            set names_already_done [_dispatch_print_helper $ti2 $outfd $names_already_done]
   730         -        } finally {
   731         -            $ti2 Release
   732         -        }
   733         -    }
   734         -
   735         -    return $names_already_done
   736         -}
   737         -
   738         -
   739         -
   740         -#
   741         -# Resolves references to parameter definition
   742         -proc twapi::_resolve_com_params_text {ti params paramnames} {
   743         -    set result [list ]
   744         -    foreach param $params paramname $paramnames {
   745         -        set paramdesc [_flatten_com_type [_resolve_com_type_text $ti [lindex $param 0]]]
   746         -        if {[llength $param] > 1 && [llength [lindex $param 1]] > 0} {
   747         -            set paramdesc "\[[lindex $param 1]\] $paramdesc"
   748         -        }
   749         -        if {[llength $param] > 2} {
   750         -            append paramdesc " [lrange $param 2 end]"
   751         -        }
   752         -        append paramdesc " $paramname"
   753         -        lappend result $paramdesc
   754         -    }
   755         -    return "([join $result {, }])"
   756         -}
   757         -
   758         -# Flattens the output of _resolve_com_type_text
   759         -proc twapi::_flatten_com_type {com_type_desc} {
   760         -    if {[llength $com_type_desc] < 2} {
   761         -        return $com_type_desc
   762         -    }
   763         -
   764         -    if {[lindex $com_type_desc 0] eq "ptr"} {
   765         -        return "[_flatten_com_type [lindex $com_type_desc 1]]*"
   766         -    } else {
   767         -        return "([lindex $com_type_desc 0] [_flatten_com_type [lindex $com_type_desc 1]])"
   768         -    }
   769         -}
   770         -
   771         -#
   772         -# Resolves typedefs
   773         -proc twapi::_resolve_com_type_text {ti typedesc} {
   774         -    
   775         -    switch -exact -- [lindex $typedesc 0] {
   776         -        26 -
   777         -        ptr {
   778         -            # Recurse to resolve any inner types
   779         -            set typedesc [list ptr [_resolve_com_type_text $ti [lindex $typedesc 1]]]
   780         -        }
   781         -        29 -
   782         -        userdefined {
   783         -            set hreftype [lindex $typedesc 1]
   784         -            set ti2 [$ti @GetRefTypeInfo $hreftype]
   785         -            set typedesc "[$ti2 @GetName]"
   786         -            $ti2 Release
   787         -        }
   788         -        default {
   789         -            set typedesc [_vttype_to_string $typedesc]
   790         -        }
   791         -    }
   792         -
   793         -    return $typedesc
   794         -}
   795         -
   796         -
   797         -#
   798         -# Given a COM type descriptor, resolved all user defined types (UDT) in it
   799         -# The descriptor must be in raw form as returned by the C code
   800         -proc twapi::_resolve_comtype {ti typedesc} {
   801         -    
   802         -    if {[lindex $typedesc 0] == 26} {
   803         -        # VT_PTR - {26 INNER_TYPEDESC}
   804         -        # If pointing to a UDT, convert to appropriate base type if possible
   805         -        set inner [_resolve_comtype $ti [lindex $typedesc 1]]
   806         -        if {[lindex $inner 0] == 29} {
   807         -            # When the referenced type is a UDT (29) which is actually
   808         -            # a dispatch or other interface, replace the
   809         -            # "pointer to UDT" with VT_DISPATCH/VT_INTERFACE
   810         -            switch -exact -- [lindex $inner 1] {
   811         -                dispatch  {set typedesc [list 9]}
   812         -                interface {set typedesc [list 13]}
   813         -                default {
   814         -                    # TBD - need to decode all the other types (record etc.)
   815         -                    set typedesc [list 26 $inner]
   816         -                }
   817         -            }
   818         -        } else {
   819         -            set typedesc [list 26 $inner]
   820         -        }
   821         -    } elseif {[lindex $typedesc 0] == 29} {
   822         -        # VT_USERDEFINED - {29 HREFTYPE}
   823         -        set ti2 [$ti @GetRefTypeInfo [lindex $typedesc 1]]
   824         -        array set tattr [$ti2 @GetTypeAttr -guid -typekind]
   825         -        if {$tattr(-typekind) eq "enum"} {
   826         -            set typedesc [list 3]; # 3 -> i4
   827         -        } else {
   828         -            if {$tattr(-typekind) eq "alias"} {
   829         -                set typedesc [_resolve_comtype $ti2 [kl_get [$ti2 GetTypeAttr] tdescAlias]]
   830         -            } else {
   831         -                set typedesc [list 29 $tattr(-typekind) $tattr(-guid)]
   832         -            }
   833         -        }
   834         -        $ti2 Release
   835         -    }
   836         -
   837         -    return $typedesc
   838         -}
   839         -
   840         -proc twapi::_resolve_params_for_prototype {ti paramdescs} {
   841         -    set params {}
   842         -    foreach paramdesc $paramdescs {
   843         -        lappend params \
   844         -            [lreplace $paramdesc 0 0 [::twapi::_resolve_comtype $ti [lindex $paramdesc 0]]]
   845         -    }
   846         -    return $params
   847         -}
   848         -
   849         -proc twapi::_variant_values_from_safearray {sa ndims {raw false} {addref false} {lcid 0}} {
   850         -    set result {}
   851         -    if {[incr ndims -1] > 0} {
   852         -	foreach elem $sa {
   853         -	    lappend result [_variant_values_from_safearray $elem $ndims $raw $addref $lcid]
   854         -	}
   855         -    } else {
   856         -	foreach elem $sa {
   857         -	    lappend result [twapi::variant_value $elem $raw $addref $lcid]
   858         -	}
   859         -    }
   860         -    return $result
   861         -}
   862         -
   863         -proc twapi::outvar {varname} { return [Twapi_InternalCast outvar $varname] }
   864         -
   865         -# TBD - document
   866         -# Returns a string value from a formatted variant value pair {VT_xxx value}
   867         -# $addref controls whether we do an AddRef when the value is a pointer to
   868         -# an interface. $raw controls whether interface pointers are returned
   869         -# as raw interface handles or objects.
   870         -proc twapi::variant_value {variant raw addref lcid} {
   871         -    # TBD - format appropriately depending on variant type for dates and
   872         -    # currency
   873         -    if {[llength $variant] == 0} {
   874         -        return ""
   875         -    }
   876         -    set vt [lindex $variant 0]
   877         -
   878         -    if {$vt & 0x2000} {
   879         -        # VT_ARRAY - second element is {dimensions value}
   880         -        if {[llength $variant] < 2} {
   881         -            return [list ]
   882         -        }
   883         -        lassign [lindex $variant 1] dimensions values
   884         -        set vt [expr {$vt & ~ 0x2000}]
   885         -        if {$vt == 12} {
   886         -            # Array of variants. Recursively convert values
   887         -            return [_variant_values_from_safearray \
   888         -                        $values \
   889         -                        [expr {[llength $dimensions] / 2}] \
   890         -                        $raw $addref $lcid]
   891         -        } else {
   892         -            return $values
   893         -        }
   894         -    } else {
   895         -        if {$vt == 9} {
   896         -            set idisp [lindex $variant 1]; # May be NULL!
   897         -            if {$addref && ! [pointer_null? $idisp]} {
   898         -                IUnknown_AddRef $idisp
   899         -            }
   900         -            if {$raw} {
   901         -                return $idisp
   902         -            } else {
   903         -                # Note comobj_idispatch takes care of NULL
   904         -                return [comobj_idispatch $idisp 0 "" $lcid]
   905         -            }
   906         -        } elseif {$vt == 13} {
   907         -            set iunk [lindex $variant 1]; # May be NULL!
   908         -            if {$addref && ! [pointer_null? $iunk]} {
   909         -                IUnknown_AddRef $iunk
   910         -            }
   911         -            if {$raw} {
   912         -                return $iunk
   913         -            } else {
   914         -                return [make_interface_proxy $iunk]
   915         -            }
   916         -        }
   917         -    }
   918         -    return [lindex $variant 1]
   919         -}
   920         -
   921         -proc twapi::variant_type {variant} {
   922         -    return [lindex $variant 0]
   923         -}
   924         -
   925         -proc twapi::vt_null {} {
   926         -    return [tclcast null ""]
   927         -}
   928         -
   929         -proc twapi::vt_empty {} {
   930         -    return [tclcast empty ""]
   931         -}
   932         -
   933         -#
   934         -# General dispatcher for callbacks from event sinks. Invokes the actual
   935         -# registered script after mapping dispid's
   936         -proc twapi::_eventsink_callback {comobj script callee args} {
   937         -    # Check if the comobj is still active
   938         -    if {[llength [info commands $comobj]] == 0} {
   939         -        if {$::twapi::log_config(twapi_com)} {
   940         -            debuglog "COM event received for inactive object"
   941         -        }
   942         -        return;                         # Object has gone away, ignore
   943         -    }
   944         -
   945         -    set retcode [catch {
   946         -        # We are invoked with cooked values so no need to call variant_value
   947         -        uplevel #0 $script [list $callee] $args
   948         -    } result]
   949         -
   950         -    if {$::twapi::log_config(twapi_com) && $retcode} {
   951         -        debuglog "Event sink callback error ($retcode): $result\n$::errorInfo"
   952         -    }
   953         -
   954         -    # $retcode is returned as HRESULT by the Invoke
   955         -    return -code $retcode $result
   956         -}
   957         -
   958         -#
   959         -# Return clsid from a string. If $clsid is a valid CLSID - returns as is
   960         -# else tries to convert it from progid. An error is generated if neither
   961         -# works
   962         -proc twapi::_convert_to_clsid {comid} {
   963         -    if {! [Twapi_IsValidGUID $comid]} {
   964         -        return [progid_to_clsid $comid]
   965         -    }
   966         -    return $comid
   967         -}
   968         -
   969         -#
   970         -# Format a prototype definition for human consumption
   971         -# Proto is in the form {DISPID LCID INVOKEFLAGS RETTYPE PARAMTYPES PARAMNAMES}
   972         -proc twapi::_format_prototype {name proto} {
   973         -    set dispid_lcid [lindex $proto 0]/[lindex $proto 1]
   974         -    set ret_type [_vttype_to_string [lindex $proto 3]]
   975         -    set invkind [_invkind_to_string [lindex $proto 2]]
   976         -    # Distinguish between no parameters and parameters not known
   977         -    set paramstr ""
   978         -    if {[llength $proto] > 4} {
   979         -        set params {}
   980         -        foreach param [lindex $proto 4] paramname [lindex $proto 5] {
   981         -            if {[string length $paramname]} {
   982         -                set paramname " $paramname"
   983         -            }
   984         -            lassign $param type paramdesc
   985         -            set type [_vttype_to_string $type]
   986         -            set parammods [_paramflags_to_tokens [lindex $paramdesc 0]]
   987         -            if {[llength [lindex $paramdesc 1]]} {
   988         -                # Default specified
   989         -                lappend parammods "default:[lindex [lindex $paramdesc 1] 1]"
   990         -            }
   991         -            lappend params "\[$parammods\] $type$paramname"
   992         -        }
   993         -        set paramstr " ([join $params {, }])"
   994         -    }
   995         -    return "$dispid_lcid $invkind $ret_type ${name}${paramstr}"
   996         -}
   997         -
   998         -# Convert parameter modifiers to string tokens.
   999         -# modifiers is list of integer flags or tokens.
  1000         -proc twapi::_paramflags_to_tokens {modifiers} {
  1001         -    array set tokens {}
  1002         -    foreach mod $modifiers {
  1003         -        if {! [string is integer -strict $mod]} {
  1004         -            # mod is a token itself
  1005         -            set tokens($mod) ""
  1006         -        } else {
  1007         -            foreach tok [_make_symbolic_bitmask $mod {
  1008         -                in 1
  1009         -                out 2
  1010         -                lcid 4
  1011         -                retval 8
  1012         -                optional 16
  1013         -                hasdefault 32
  1014         -                hascustom  64
  1015         -            }] {
  1016         -                set tokens($tok) ""
  1017         -            }
  1018         -        }
  1019         -    }
  1020         -
  1021         -    # For cosmetic reasons, in/out should be first and remaining sorted
  1022         -    # Also (in,out) -> inout
  1023         -    if {[info exists tokens(in)]} {
  1024         -        if {[info exists tokens(out)]} {
  1025         -            set inout [list inout]
  1026         -            unset tokens(in)
  1027         -            unset tokens(out)
  1028         -        } else {
  1029         -            set inout [list in]
  1030         -            unset tokens(in)
  1031         -        }
  1032         -    } else {
  1033         -        if {[info exists tokens(out)]} {
  1034         -            set inout [list out]
  1035         -            unset tokens(out)
  1036         -        }
  1037         -    }
  1038         -
  1039         -    if {[info exists inout]} {
  1040         -        return [linsert [lsort [array names tokens]] 0 $inout]
  1041         -    } else {
  1042         -        return [lsort [array names tokens]]
  1043         -    }
  1044         -}
  1045         -
  1046         -#
  1047         -# Map method invocation code to string
  1048         -# Return code itself if no match
  1049         -proc twapi::_invkind_to_string {code} {
  1050         -    return [kl_get {
  1051         -        1  func
  1052         -        2  propget
  1053         -        4  propput
  1054         -        8  propputref
  1055         -    } $code $code]
  1056         -}
  1057         -
  1058         -#
  1059         -# Map string method invocation symbol to code
  1060         -# Error if no match and not an integer
  1061         -proc twapi::_string_to_invkind {s} {
  1062         -    if {[string is integer $s]} { return $s }
  1063         -    return [kl_get {
  1064         -        func    1
  1065         -        propget 2
  1066         -        propput 4
  1067         -        propputref 8
  1068         -    } $s]
  1069         -}
  1070         -
  1071         -
  1072         -#
  1073         -# Convert a VT typedef to a string
  1074         -# vttype may be nested
  1075         -proc twapi::_vttype_to_string {vttype} {
  1076         -    set vts [_vtcode_to_string [lindex $vttype 0]]
  1077         -    if {[llength $vttype] < 2} {
  1078         -        return $vts
  1079         -    }
  1080         -
  1081         -    return [list $vts [_vttype_to_string [lindex $vttype 1]]]
  1082         -}
  1083         -
  1084         -#
  1085         -# Convert VT codes to strings
  1086         -proc twapi::_vtcode_to_string {vt} {
  1087         -    return [kl_get {
  1088         -        2        i2
  1089         -        3        i4
  1090         -        4       r4
  1091         -        5       r8
  1092         -        6       cy
  1093         -        7       date
  1094         -        8       bstr
  1095         -        9       idispatch
  1096         -        10       error
  1097         -        11       bool
  1098         -        12       variant
  1099         -        13       iunknown
  1100         -        14       decimal
  1101         -        16       i1
  1102         -        17       ui1
  1103         -        18       ui2
  1104         -        19       ui4
  1105         -        20       i8
  1106         -        21       ui8
  1107         -        22       int
  1108         -        23       uint
  1109         -        24       void
  1110         -        25       hresult
  1111         -        26       ptr
  1112         -        27       safearray
  1113         -        28       carray
  1114         -        29       userdefined
  1115         -        30       lpstr
  1116         -        31       lpwstr
  1117         -        36       record
  1118         -    } $vt $vt]
  1119         -}
  1120         -
  1121         -proc twapi::_string_to_base_vt {tok} {
  1122         -    # Only maps base VT tokens to numeric value
  1123         -    # TBD - record and userdefined?
  1124         -    return [dict get {
  1125         -        i2 2
  1126         -        i4 3
  1127         -        r4 4
  1128         -        r8 5
  1129         -        cy 6
  1130         -        date 7
  1131         -        bstr 8
  1132         -        idispatch 9
  1133         -        error 10
  1134         -        bool 11
  1135         -        iunknown 13
  1136         -        decimal 14
  1137         -        i1 16
  1138         -        ui1 17
  1139         -        ui2 18
  1140         -        ui4 19
  1141         -        i8 20
  1142         -        ui8 21
  1143         -        int 22
  1144         -        uint 23
  1145         -        hresult 25
  1146         -        userdefined 29
  1147         -        record 36
  1148         -    } [string tolower $tok]]
  1149         -
  1150         -}
  1151         -
  1152         -#
  1153         -# Get ADSI provider service
  1154         -proc twapi::_adsi {{prov WinNT} {path {//.}}} {
  1155         -    return [comobj_object "${prov}:$path"]
  1156         -}
  1157         -
  1158         -# Get cached IDispatch and IUNknown IID's
  1159         -proc twapi::_iid_iunknown {} {
  1160         -    return $::twapi::_name_to_iid_cache(iunknown)
  1161         -}
  1162         -proc twapi::_iid_idispatch {} {
  1163         -    return $::twapi::_name_to_iid_cache(idispatch)
  1164         -}
  1165         -
  1166         -#
  1167         -# Return IID and name given a IID or name
  1168         -proc twapi::_resolve_iid {name_or_iid} {
  1169         -
  1170         -    # IID -> name mapping is more efficient so first assume it is
  1171         -    # an IID else we will unnecessarily trundle through the whole
  1172         -    # registry area looking for an IID when we already have it
  1173         -    # Assume it is a name
  1174         -    set other [iid_to_name $name_or_iid]
  1175         -    if {$other ne ""} {
  1176         -        # It was indeed the IID. Return the pair
  1177         -        return [list $name_or_iid $other]
  1178         -    }
  1179         -
  1180         -    # Else resolve as a name
  1181         -    set other [name_to_iid $name_or_iid]
  1182         -    if {$other ne ""} {
  1183         -        # Yep
  1184         -        return [list $other $name_or_iid]
  1185         -    }
  1186         -
  1187         -    win32_error 0x80004002 "Could not find IID $name_or_iid"
  1188         -}
  1189         -
  1190         -
  1191         -namespace eval twapi {
  1192         -    # Enable use of TclOO for new Tcl versions. To override setting
  1193         -    # applications should define and set before sourcing this file.
  1194         -    variable use_tcloo_for_com 
  1195         -    if {![info exists use_tcloo_for_com]} {
  1196         -        set use_tcloo_for_com [package vsatisfies [package require Tcl] 8.6b2]
  1197         -    }
  1198         -    if {$use_tcloo_for_com} {
  1199         -        interp alias {} ::twapi::class {} ::oo::class
  1200         -        proc ::oo::define::twapi_exportall {} {
  1201         -            uplevel 1 export [info class methods [lindex [info level -1] 1] -private]
  1202         -        }
  1203         -        proc comobj? {cobj} {
  1204         -            # TBD - would it be faster to keep explicit track through
  1205         -            # a dictionary ?
  1206         -            set cobj [uplevel 1 [list namespace which -command $cobj]]
  1207         -            if {[info object isa object $cobj] &&
  1208         -                [info object isa typeof $cobj ::twapi::Automation]} {
  1209         -                return 1
  1210         -            } else {
  1211         -                return 0
  1212         -            }
  1213         -        }
  1214         -        proc comobj_instances {} {
  1215         -            set comobj_classes [list ::twapi::Automation]
  1216         -            set objs {}
  1217         -            while {[llength $comobj_classes]} {
  1218         -                set comobj_classes [lassign $comobj_classes class]
  1219         -                lappend objs {*}[info class instances $class]
  1220         -                lappend comobj_classes {*}[info class subclasses $class]
  1221         -            }
  1222         -            # Get rid of dups which may occur if subclasses use
  1223         -            # multiple (diamond type) inheritance
  1224         -            return [lsort -unique $objs]
  1225         -        }
  1226         -    } else {
  1227         -        package require metoo
  1228         -        interp alias {} ::twapi::class {} ::metoo::class
  1229         -        namespace eval ::metoo::define {
  1230         -            proc twapi_exportall {args} {
  1231         -                # args is dummy to match metoo's class definition signature
  1232         -                # Nothing to do, all methods are metoo are public
  1233         -            }
  1234         -        }
  1235         -        proc comobj? {cobj} {
  1236         -            set cobj [uplevel 1 [list namespace which -command $cobj]]
  1237         -            return [metoo::introspect object isa $cobj ::twapi::Automation]
  1238         -        }
  1239         -        proc comobj_instances {} {
  1240         -            return [metoo::introspect object list ::twapi::Automation]
  1241         -        }
  1242         -    }
  1243         -
  1244         -    # The prototype cache is indexed a composite key consisting of
  1245         -    #  - the GUID of the interface,
  1246         -    #  - the name of the function
  1247         -    #  - the LCID
  1248         -    #  - the invocation kind (as an integer)
  1249         -    # Each value contains the full prototype in a form
  1250         -    # that can be passed to IDispatch_Invoke. This is a list with the
  1251         -    # elements {DISPID LCID INVOKEFLAGS RETTYPE PARAMTYPES PARAMNAMES}
  1252         -    # Here PARAMTYPES is a list each element of which describes a
  1253         -    # parameter in the following format:
  1254         -    #     {TYPE {FLAGS DEFAULT} NAMEDARGVALUE} where DEFAULT is optional
  1255         -    # and NAMEDARGVALUE only appears (optionally) when the prototype is
  1256         -    # passed to Invoke, not in the cached prototype itself.
  1257         -    # PARAMNAMES is list of parameter names in order and is
  1258         -    # only present if PARAMTYPES is also present.
  1259         -    
  1260         -    variable _dispatch_prototype_cache
  1261         -    array set _dispatch_prototype_cache {}
  1262         -}
  1263         -
  1264         -
  1265         -interp alias {} twapi::_dispatch_prototype_get {} twapi::dispatch_prototype_get
  1266         -proc twapi::dispatch_prototype_get {guid name lcid invkind vproto} {
  1267         -    variable _dispatch_prototype_cache
  1268         -    set invkind [::twapi::_string_to_invkind $invkind]
  1269         -    if {[info exists _dispatch_prototype_cache($guid,$name,$lcid,$invkind)]} {
  1270         -        # Note this may be null if that name does not exist in the interface
  1271         -        upvar 1 $vproto proto
  1272         -        set proto $_dispatch_prototype_cache($guid,$name,$lcid,$invkind)
  1273         -        return 1
  1274         -    }
  1275         -    return 0
  1276         -}
  1277         -
  1278         -# Update a prototype in cache. Note lcid and invkind cannot be
  1279         -# picked up from prototype since it might be empty.
  1280         -interp alias {} twapi::_dispatch_prototype_set {} twapi::dispatch_prototype_set
  1281         -proc twapi::dispatch_prototype_set {guid name lcid invkind proto} {
  1282         -    # If the prototype does not contain the 5th element (params)
  1283         -    # it is a constructed prototype and we do NOT cache it as the
  1284         -    # disp id can change. Note empty prototypes are cached so
  1285         -    # we don't keep looking up something that does not exist
  1286         -    # Bug 130
  1287         -
  1288         -    if {[llength $proto] == 4} {
  1289         -        return
  1290         -    }
  1291         -
  1292         -    variable _dispatch_prototype_cache
  1293         -    set invkind [_string_to_invkind $invkind]
  1294         -    set _dispatch_prototype_cache($guid,$name,$lcid,$invkind) $proto
  1295         -    return
  1296         -}
  1297         -
  1298         -# Explicitly set prototypes for a guid 
  1299         -# protolist is a list of alternating name and prototype pairs.
  1300         -# Each prototype must contain the LCID and invkind fields
  1301         -proc twapi::_dispatch_prototype_load {guid protolist} {
  1302         -    foreach {name proto} $protolist {
  1303         -        dispatch_prototype_set $guid $name [lindex $proto 1] [lindex $proto 2] $proto
  1304         -    }
  1305         -}
  1306         -
  1307         -proc twapi::_parse_dispatch_paramdef {paramdef} {
  1308         -    set errormsg "Invalid parameter or return type declaration '$paramdef'"
  1309         -
  1310         -    set paramregex {^(\[[^\]]*\])?\s*(\w+)\s*(\[\s*\])?\s*([*]?)\s*(\w+)?$}
  1311         -    if {![regexp $paramregex [string trim $paramdef] def attrs paramtype safearray ptr paramname]} {
  1312         -        error $errormsg
  1313         -    }
  1314         -
  1315         -    if {[string length $paramname]} {
  1316         -        lappend paramnames $paramname
  1317         -    }
  1318         -    # attrs can be in, out, opt separated by spaces
  1319         -    set paramflags 0
  1320         -    foreach attr [string range $attrs 1 end-1] {
  1321         -        switch -exact -- $attr {
  1322         -            in {set paramflags [expr {$paramflags | 1}]}
  1323         -            out {set paramflags [expr {$paramflags | 2}]}
  1324         -            inout {set paramflags [expr {$paramflags | 3}]}
  1325         -            opt -
  1326         -            optional {set paramflags [expr {$paramflags | 16}]}
  1327         -            default {error "Unknown parameter attribute $attr"}
  1328         -        }
  1329         -    }
  1330         -    if {($paramflags & 3) == 0} {
  1331         -        set paramflags [expr {$paramflags | 1}]; # in param if unspecified
  1332         -    }
  1333         -    # Resolve parameter type. It can be 
  1334         -    #  - a safearray of base types or "variant"s (not pointers)
  1335         -    #  - a pointer to a base type
  1336         -    #  - a pointer to a safearray
  1337         -    #  - a base type or "variant"
  1338         -    switch -exact -- $paramtype {
  1339         -        variant { set paramtype 12 }
  1340         -        void    { set paramtype 24 }
  1341         -        default { set paramtype [_string_to_base_vt $paramtype] }
  1342         -    }
  1343         -    if {[string length $safearray]} {
  1344         -        if {$paramtype == 24} {
  1345         -            # Safearray of type void is an invalid type decl
  1346         -            error $errormsg
  1347         -        }
  1348         -        set paramtype [list 27 $paramtype]
  1349         -    }
  1350         -    if {[string length $ptr]} {
  1351         -        if {$paramtype == 24} {
  1352         -            # Pointer to type void is an invalid type
  1353         -            error $errormsg
  1354         -        }
  1355         -        set paramtype [list 26 $paramtype]
  1356         -    }
  1357         -
  1358         -    return [list $paramflags $paramtype $paramname]
  1359         -}
  1360         -
  1361         -proc twapi::define_dispatch_prototypes {guid protos args} {
  1362         -    array set opts [parseargs args {
  1363         -        {lcid.int 0}
  1364         -    } -maxleftover 0]
  1365         -
  1366         -    set guid [canonicalize_guid $guid]
  1367         -
  1368         -    set defregx {^\s*(\w+)\s+(\d+)\s+(\w[^\(]*)\(([^\)]*)\)(.*)$}
  1369         -    set parsed_protos {}
  1370         -    # Loop picking out one prototype in each interation
  1371         -    while {[regexp $defregx $protos -> membertype memid rettype paramstring protos]} {
  1372         -        set params {}
  1373         -        set paramnames {}
  1374         -        foreach paramdef [split $paramstring ,] {
  1375         -            lassign [_parse_dispatch_paramdef $paramdef] paramflags paramtype paramname
  1376         -            if {[string length $paramname]} {
  1377         -                lappend paramnames $paramname
  1378         -            }
  1379         -            lappend params [list $paramtype [list $paramflags]]
  1380         -        }
  1381         -        if {[llength $paramnames] &&
  1382         -            [llength $params] != [llength $paramnames]} {
  1383         -            error "Missing parameter name in '$paramstring'. All parameter names must be specified or none at all."
  1384         -        }
  1385         -
  1386         -        lassign [_parse_dispatch_paramdef $rettype] _ rettype name 
  1387         -        set invkind [_string_to_invkind $membertype]
  1388         -        set proto [list $memid $opts(lcid) $invkind $rettype $params $paramnames]
  1389         -        lappend parsed_protos $name $proto
  1390         -    }
  1391         -
  1392         -    set protos [string trim $protos]
  1393         -    if {[string length $protos]} {
  1394         -        error "Invalid dispatch prototype: '$protos'"
  1395         -    }
  1396         -    
  1397         -    _dispatch_prototype_load $guid $parsed_protos
  1398         -}
  1399         -
  1400         -# Used to track when interface proxies are renamed/deleted
  1401         -proc twapi::_interface_proxy_tracer {ifc oldname newname op} {
  1402         -    variable _interface_proxies
  1403         -    if {$op eq "rename"} {
  1404         -        if {$oldname eq $newname} return
  1405         -        set _interface_proxies($ifc) $newname
  1406         -    } else {
  1407         -        unset _interface_proxies($ifc)
  1408         -    }
  1409         -}
  1410         -
  1411         -
  1412         -# Return a COM interface proxy object for the specified interface.
  1413         -# If such an object already exists, it is returned. Otherwise a new one
  1414         -# is created. $ifc must be a valid COM Interface pointer for which
  1415         -# the caller is holding a reference. Caller relinquishes ownership
  1416         -# of the interface and must solely invoke operations through the
  1417         -# returned proxy object. When done with the object, call the Release
  1418         -# method on it, NOT destroy.
  1419         -# TBD - how does this interact with security blankets ?
  1420         -proc twapi::make_interface_proxy {ifc} {
  1421         -    variable _interface_proxies
  1422         -
  1423         -    if {[info exists _interface_proxies($ifc)]} {
  1424         -        set proxy $_interface_proxies($ifc)
  1425         -        $proxy AddRef
  1426         -        if {! [pointer_null? $ifc]} {
  1427         -            # Release the caller's ref to the interface since we are holding
  1428         -            # one in the proxy object
  1429         -            ::twapi::IUnknown_Release $ifc
  1430         -        }
  1431         -    } else {
  1432         -        if {[pointer_null? $ifc]} {
  1433         -            set proxy [INullProxy new $ifc]
  1434         -        } else {
  1435         -            set ifcname [pointer_type $ifc]
  1436         -            set proxy [${ifcname}Proxy new $ifc]
  1437         -        }
  1438         -        set _interface_proxies($ifc) $proxy
  1439         -        trace add command $proxy {rename delete} [list ::twapi::_interface_proxy_tracer $ifc]
  1440         -    }
  1441         -    return $proxy
  1442         -}
  1443         -
  1444         -# "Null" object - clones IUnknownProxy but will raise error on method calls
  1445         -# We could have inherited but IUnknownProxy assumes non-null ifc so it
  1446         -# and its inherited classes do not have to check for null in every method.
  1447         -twapi::class create ::twapi::INullProxy {
  1448         -    constructor {ifc} {
  1449         -        my variable _ifc
  1450         -        # We keep the interface pointer because it encodes type information
  1451         -        if {! [::twapi::pointer_null? $ifc]} {
  1452         -            error "Attempt to create a INullProxy with non-NULL interface"
  1453         -        }
  1454         -
  1455         -        set _ifc $ifc
  1456         -
  1457         -        my variable _nrefs;   # Internal ref count (held by app)
  1458         -        set _nrefs 1
  1459         -    }
  1460         -
  1461         -    method @Null? {} { return 1 }
  1462         -    method @Type {} {
  1463         -        my variable _ifc
  1464         -        return [::twapi::pointer_type $_ifc]
  1465         -    }
  1466         -    method @Type? {type} {
  1467         -        my variable _ifc
  1468         -        return [::twapi::pointer? $_ifc $type]
  1469         -    }
  1470         -    method AddRef {} {
  1471         -        my variable _nrefs
  1472         -        # We maintain our own ref counts. _ifc is null so do not
  1473         -        # call the COM AddRef !
  1474         -        incr _nrefs
  1475         -    }
  1476         -
  1477         -    method Release {} {
  1478         -        my variable _nrefs
  1479         -        if {[incr _nrefs -1] == 0} {
  1480         -            my destroy
  1481         -        }
  1482         -    }
  1483         -
  1484         -    method DebugRefCounts {} {
  1485         -        my variable _nrefs
  1486         -
  1487         -        # Return out internal ref as well as the COM ones
  1488         -        # Note latter is always 0 since _ifc is always NULL.
  1489         -        return [list $_nrefs 0]
  1490         -    }
  1491         -
  1492         -    method QueryInterface {name_or_iid} {
  1493         -        error "Attempt to call QueryInterface called on NULL pointer"
  1494         -    }
  1495         -
  1496         -    method @QueryInterface {name_or_iid} {
  1497         -        error "Attempt to call QueryInterface called on NULL pointer"
  1498         -    }
  1499         -
  1500         -    # Parameter is for compatibility with IUnknownProxy
  1501         -    method @Interface {{addref 1}} {
  1502         -        my variable _ifc
  1503         -        return $_ifc
  1504         -    }
  1505         -
  1506         -    twapi_exportall
  1507         -}
  1508         -
  1509         -twapi::class create ::twapi::IUnknownProxy {
  1510         -    # Note caller must hold ref on the ifc. This ref is passed to
  1511         -    # the proxy object and caller must not make use of that ref
  1512         -    # unless it does an AddRef on it.
  1513         -    constructor {ifc {objclsid ""}} {
  1514         -        if {[::twapi::pointer_null? $ifc]} {
  1515         -            error "Attempt to register a NULL interface"
  1516         -        }
  1517         -
  1518         -        my variable _ifc
  1519         -        set _ifc $ifc
  1520         -
  1521         -        my variable _clsid
  1522         -        set _clsid $objclsid
  1523         -
  1524         -        my variable _blanket;   # Security blanket
  1525         -        set _blanket [list ]
  1526         -
  1527         -        # We keep an internal reference count instead of explicitly
  1528         -        # calling out to the object's AddRef/Release every time.
  1529         -        # When the internal ref count goes to 0, we will invoke the 
  1530         -        # object's "native" Release.
  1531         -        #
  1532         -        # Note the primary purpose of maintaining our internal reference counts
  1533         -        # is not efficiency by shortcutting the "native" AddRefs. It is to
  1534         -        # prevent crashes by bad application code; we can just generate an
  1535         -        # error instead by having the command go away.
  1536         -        my variable _nrefs;   # Internal ref count (held by app)
  1537         -
  1538         -        set _nrefs 1
  1539         -    }
  1540         -
  1541         -    destructor {
  1542         -        my variable _ifc
  1543         -        ::twapi::IUnknown_Release $_ifc
  1544         -    }
  1545         -
  1546         -    method AddRef {} {
  1547         -        my variable _nrefs
  1548         -        # We maintain our own ref counts. Not pass it on to the actual object
  1549         -        incr _nrefs
  1550         -    }
  1551         -
  1552         -    method Release {} {
  1553         -        my variable _nrefs
  1554         -        if {[incr _nrefs -1] == 0} {
  1555         -            my destroy
  1556         -        }
  1557         -    }
  1558         -
  1559         -    method DebugRefCounts {} {
  1560         -        my variable _nrefs
  1561         -        my variable _ifc
  1562         -
  1563         -        # Return out internal ref as well as the COM ones
  1564         -        # Note latter are unstable and only to be used for
  1565         -        # debugging
  1566         -        twapi::IUnknown_AddRef $_ifc
  1567         -        return [list $_nrefs [twapi::IUnknown_Release $_ifc]]
  1568         -    }
  1569         -
  1570         -    method QueryInterface {name_or_iid} {
  1571         -        my variable _ifc
  1572         -        lassign [::twapi::_resolve_iid $name_or_iid] iid name
  1573         -        return [::twapi::Twapi_IUnknown_QueryInterface $_ifc $iid $name]
  1574         -    }
  1575         -
  1576         -    # Same as QueryInterface except return "" instead of exception
  1577         -    # if interface not found and returns proxy object instead of interface
  1578         -    method @QueryInterface {name_or_iid {set_blanket 0}} {
  1579         -        my variable _blanket
  1580         -        ::twapi::trap {
  1581         -            set proxy [::twapi::make_interface_proxy [my QueryInterface $name_or_iid]]
  1582         -            if {$set_blanket && [llength $_blanket]} {
  1583         -                $proxy @SetSecurityBlanket $_blanket
  1584         -            }
  1585         -            return $proxy
  1586         -        } onerror {TWAPI_WIN32 0x80004002} {
  1587         -            # No such interface, return "", don't generate error
  1588         -            return ""
  1589         -        } onerror {} {
  1590         -            if {[info exists proxy]} {
  1591         -                catch {$proxy Release}
  1592         -            }
  1593         -            rethrow
  1594         -        }
  1595         -    }
  1596         -
  1597         -    method @Type {} {
  1598         -        my variable _ifc
  1599         -        return [::twapi::pointer_type $_ifc]
  1600         -    }
  1601         -
  1602         -    method @Type? {type} {
  1603         -        my variable _ifc
  1604         -        return [::twapi::pointer? $_ifc $type]
  1605         -    }
  1606         -
  1607         -    method @Null? {} {
  1608         -        my variable _ifc
  1609         -        return [::twapi::pointer_null? $_ifc]
  1610         -    }
  1611         -
  1612         -    # Returns raw interface. Caller must call IUnknown_Release on it
  1613         -    # iff addref is passed as true (default)
  1614         -    method @Interface {{addref 1}} {
  1615         -        my variable _ifc
  1616         -        if {$addref} {
  1617         -            ::twapi::IUnknown_AddRef $_ifc
  1618         -        }
  1619         -        return $_ifc
  1620         -    }
  1621         -
  1622         -    # Returns out class id - old deprecated - use GetCLSID
  1623         -    method @Clsid {} {
  1624         -        my variable _clsid
  1625         -        return $_clsid
  1626         -    }
  1627         -
  1628         -    method @GetCLSID {} {
  1629         -        my variable _clsid
  1630         -        return $_clsid
  1631         -    }
  1632         -
  1633         -    method @SetCLSID {clsid} {
  1634         -        my variable _clsid
  1635         -        set _clsid $clsid
  1636         -        return
  1637         -    }
  1638         -
  1639         -    method @SetSecurityBlanket blanket {
  1640         -        my variable _ifc _blanket
  1641         -        # In-proc components will not support IClientSecurity interface
  1642         -        # and will raise an error. That's the for the caller to be careful
  1643         -        # about.
  1644         -        twapi::CoSetProxyBlanket $_ifc {*}$blanket
  1645         -        set _blanket $blanket
  1646         -        return
  1647         -    }
  1648         -
  1649         -    method @GetSecurityBlanket {} {
  1650         -        my variable _blanket
  1651         -        return $_blanket
  1652         -    }
  1653         -    
  1654         -
  1655         -    twapi_exportall
  1656         -}
  1657         -
  1658         -twapi::class create ::twapi::IDispatchProxy {
  1659         -    superclass ::twapi::IUnknownProxy
  1660         -
  1661         -    destructor {
  1662         -        my variable _typecomp
  1663         -        if {[info exists _typecomp] && $_typecomp ne ""} {
  1664         -            $_typecomp Release
  1665         -        }
  1666         -        next
  1667         -    }
  1668         -
  1669         -    method GetTypeInfoCount {} {
  1670         -        my variable _ifc
  1671         -        return [::twapi::IDispatch_GetTypeInfoCount $_ifc]
  1672         -    }
  1673         -
  1674         -    # names is list - method name followed by parameter names
  1675         -    # Returns list of name dispid pairs
  1676         -    method GetIDsOfNames {names {lcid 0}} {
  1677         -        my variable _ifc
  1678         -        return [::twapi::IDispatch_GetIDsOfNames $_ifc $names $lcid]
  1679         -    }
  1680         -
  1681         -    # Get dispid of a method (without parameter names)
  1682         -    method @GetIDOfOneName {name {lcid 0}} {
  1683         -        return [lindex [my GetIDsOfNames [list $name] $lcid] 1]
  1684         -    }
  1685         -
  1686         -    method GetTypeInfo {{infotype 0} {lcid 0}} {
  1687         -        my variable _ifc
  1688         -        if {$infotype != 0} {error "Parameter infotype must be 0"}
  1689         -        return [::twapi::IDispatch_GetTypeInfo $_ifc $infotype $lcid]
  1690         -    }
  1691         -
  1692         -    method @GetTypeInfo {{lcid 0}} {
  1693         -        return [::twapi::make_interface_proxy [my GetTypeInfo 0 $lcid]]
  1694         -    }
  1695         -
  1696         -    method Invoke {prototype args} {
  1697         -        my variable _ifc
  1698         -        if {[llength $prototype] == 0 && [llength $args] == 0} {
  1699         -            # Treat as a property get DISPID_VALUE (default value)
  1700         -            # {dispid=0, lcid=0 cmd=propget(2) ret type=bstr(8) {} (no params)}
  1701         -            set prototype {0 0 2 8 {}}
  1702         -        } else {
  1703         -            # TBD - optimize by precomputing if a prototype needs this processing
  1704         -            # If any arguments are comobjs, may need to replace with the 
  1705         -            # IDispatch interface.
  1706         -            # Moreover, we have to manage the reference counts for both
  1707         -            # IUnknown and IDispatch - 
  1708         -            #  - If the parameter is an IN parameter, ref counts do not need
  1709         -            #    to change.
  1710         -            #  - If the parameter is an OUT parameter, we are not passing
  1711         -            #    an interface in, so nothing to do
  1712         -            #  - If the parameter is an INOUT, we need to AddRef it since
  1713         -            #    the COM method will Release it when storing a replacement
  1714         -            # HERE WE ONLY DO THE CHECK FOR COMOBJ. The AddRef checks are
  1715         -            # DONE IN THE C CODE (if necessary)
  1716         -
  1717         -            set iarg -1
  1718         -            set args2 {}
  1719         -            foreach arg $args {
  1720         -                incr iarg
  1721         -                # TBD - optimize this loop
  1722         -                set argtype  [lindex $prototype 4 $iarg 0]
  1723         -                set argflags 0
  1724         -                if {[llength [lindex $prototype 4 $iarg 1]]} {
  1725         -                    set argflags [lindex $prototype 4 $iarg 1 0]
  1726         -                }
  1727         -                if {$argflags & 1} {
  1728         -                    # IN param
  1729         -                    if {$argflags & 2} {
  1730         -                        # IN/OUT
  1731         -                        # We currently do NOT handle a In/Out - skip for now TBD
  1732         -                        # In the future we will have to check contents of
  1733         -                        # the passed arg as a variable in the CALLER's context
  1734         -                    } else {
  1735         -                        # Pure IN param. Check if it is VT_DISPATCH or
  1736         -                        # VT_VARIANT. Else nothing
  1737         -                        # to do
  1738         -                        if {[lindex $argtype 0] == 26} {
  1739         -                            # Pointer, get base type
  1740         -                            set argtype [lindex $argtype 1]
  1741         -                        }
  1742         -                        if {[lindex $argtype 0] == 9 || [lindex $argtype 0] == 12} {
  1743         -                            # If a comobj was passed, need to extract the
  1744         -                            # dispatch pointer.
  1745         -                            # We do not want change the internal type so
  1746         -                            # save it since comobj? changes it to cmdProc.
  1747         -                            # Moreover, do not check for some types that
  1748         -                            # could not be a comobj. In particular,
  1749         -                            # if a list type, we do not even check
  1750         -                            # because it cannot be a comobj and even checking
  1751         -                            # will result in nested list types being
  1752         -                            # destroyed which affects safearray type detection
  1753         -                            if {[twapi::tcltype $arg] ni {bytecode TwapiOpaque list int double bytearray dict wideInt booleanString}} {
  1754         -                                if {[twapi::comobj? $arg]} {
  1755         -                                    # Note we do not addref when getting the interface
  1756         -                                    # (last param 0) because not necessary for IN
  1757         -                                    # params, AND it is the C code's responsibility
  1758         -                                    # anyways
  1759         -                                    set arg [$arg -interface 0]
  1760         -                                }
  1761         -                            }
  1762         -                        }
  1763         -                    }
  1764         -
  1765         -                } else {
  1766         -                    # Not an IN param. Nothing to be done
  1767         -                }
  1768         -                
  1769         -                lappend args2 $arg
  1770         -            }
  1771         -            set args $args2
  1772         -        }
  1773         -
  1774         -        # The uplevel is so that if some parameters are output, the varnames
  1775         -        # are resolved in caller
  1776         -        uplevel 1 [list ::twapi::IDispatch_Invoke $_ifc $prototype] $args
  1777         -    }
  1778         -
  1779         -    # Methods are tried in the order specified by invkinds.
  1780         -    method @Invoke {name invkinds lcid params {namedargs {}}} {
  1781         -        if {$name eq ""} {
  1782         -            # Default method
  1783         -            return [uplevel 1 [list [self] Invoke {}] $params]
  1784         -        } else {
  1785         -            set nparams [llength $params]
  1786         -
  1787         -            # We will try for each invkind to match. matches can be of
  1788         -            # different degrees, in descending priority -
  1789         -            # 1. prototype has parameter info and num params match exactly
  1790         -            # 2. prototype has parameter info and num params is greater
  1791         -            #    than supplied arguments (assumes others have defaults)
  1792         -            # 3. prototype has no parameter information
  1793         -            # Within these classes, the order of invkinds determines
  1794         -            # priority
  1795         -
  1796         -            foreach invkind $invkinds {
  1797         -                set proto [my @Prototype $name $invkind $lcid]
  1798         -                if {[llength $proto]} {
  1799         -                    if {[llength $proto] < 5} {
  1800         -                        # No parameter information
  1801         -                        lappend class3 $proto
  1802         -                    } else {
  1803         -                        if {[llength [lindex $proto 4]] == $nparams} {
  1804         -                            lappend class1 $proto
  1805         -                            break; # Class 1 match, no need to try others
  1806         -                        } elseif {[llength [lindex $proto 4]] > $nparams} {
  1807         -                            lappend class2 $proto
  1808         -                        } else {
  1809         -                            # Ignore - proto has fewer than supplied params
  1810         -                            # Could not be a match
  1811         -                        }
  1812         -                    }
  1813         -                }
  1814         -            }
  1815         -
  1816         -            # For exact match (class1), we do not need the named arguments as
  1817         -            # positional arguments take priority. When number of passed parameters
  1818         -            # is fewer than those in prototype, check named arguments and use those
  1819         -            # values. If no parameter information, we can't use named arguments
  1820         -            # anyways.
  1821         -            if {[info exists class1]} {
  1822         -                set proto [lindex $class1 0]
  1823         -            } elseif {[info exists class2]} {
  1824         -                set proto [lindex $class2 0]
  1825         -                # If we are passed named arguments AND the prototype also
  1826         -                # has parameter name information, replace the default values
  1827         -                # in the parameter definitions with the named arg value if
  1828         -                # it exists.
  1829         -                if {[llength $namedargs] &&
  1830         -                    [llength [set paramnames [lindex $proto 5]]]} {
  1831         -                    foreach {paramname paramval} $namedargs {
  1832         -                        set paramindex [lsearch -nocase $paramnames $paramname]
  1833         -                        if {$paramindex < 0} {
  1834         -                            twapi::win32_error 0x80020004 "No parameter with name '$paramname' found for method '$name'"
  1835         -                        }
  1836         -
  1837         -                        # Set the default value field of the
  1838         -                        # appropriate parameter to the named arg value
  1839         -                        set paramtype [lindex $proto 4 $paramindex 0]
  1840         -
  1841         -                        # If parameter is VT_DISPATCH or VT_VARIANT, 
  1842         -                        # convert from comobj if necessary.
  1843         -                        if {$paramtype == 9 || $paramtype == 12} {
  1844         -                            # We do not want to change the internal type by
  1845         -                            # shimmering. See similar comments in Invoke
  1846         -                            if {[twapi::tcltype $paramval] ni {"" TwapiOpaque list int double bytearray dict wideInt booleanString}} {
  1847         -                                if {[::twapi::comobj? $paramval]} {
  1848         -                                    # Note no AddRef when getting the interface
  1849         -                                    # (last param 0) because it is the C code's
  1850         -                                    # responsibility based on in/out direction
  1851         -                                    set paramval [$paramval -interface 0]
  1852         -                                }
  1853         -                            }
  1854         -                        }
  1855         -
  1856         -                        # Replace the default value field for that param def
  1857         -                        lset proto 4 $paramindex [linsert [lrange [lindex $proto 4 $paramindex] 0 1] 2 $paramval]
  1858         -                    }
  1859         -                }
  1860         -            } elseif {[info exists class3]} {
  1861         -                set proto [lindex $class3 0]
  1862         -            } else {
  1863         -                # No prototype via typecomp / typeinfo available. No lcid worked.
  1864         -                # We have to use the last resort of GetIDsOfNames
  1865         -                set dispid [my @GetIDOfOneName [list $name] 0]
  1866         -                # TBD - should we cache result ? Probably not.
  1867         -                if {$dispid ne ""} {
  1868         -                    # Note params field (last) is missing signifying we do not
  1869         -                    # know prototypes
  1870         -                    set proto [list $dispid 0 [lindex $invkinds 0] 8]
  1871         -                } else {
  1872         -                    twapi::win32_error 0x80020003 "No property or method found with name '$name'."
  1873         -                }
  1874         -            }
  1875         -
  1876         -            # Need uplevel so by-ref param vars are resolved correctly
  1877         -            return [uplevel 1 [list [self] Invoke $proto] $params]
  1878         -        }
  1879         -    }
  1880         -
  1881         -    # Get prototype that match the specified name
  1882         -    method @Prototype {name invkind lcid} {
  1883         -        my variable  _ifc  _guid  _typecomp
  1884         -
  1885         -        # Always need the GUID so get it we have not done so already
  1886         -        if {![info exists _guid]} {
  1887         -            my @InitTypeCompAndGuid
  1888         -        }
  1889         -        # Note above call may still have failed to init _guid
  1890         -
  1891         -        # If we have been through here before and have our guid,
  1892         -        # check if a prototype exists and return it. 
  1893         -        if {[info exists _guid] && $_guid ne "" &&
  1894         -            [::twapi::_dispatch_prototype_get $_guid $name $lcid $invkind proto]} {
  1895         -            return $proto
  1896         -        }
  1897         -
  1898         -        # Not in cache, have to look for it
  1899         -        # Use the ITypeComp for this interface if we do not
  1900         -        # already have it. We trap any errors because we will retry with
  1901         -        # different LCID's below.
  1902         -        set proto {}
  1903         -        if {![info exists _typecomp]} {
  1904         -            my @InitTypeCompAndGuid
  1905         -        }
  1906         -        if {$_typecomp ne ""} {
  1907         -            ::twapi::trap {
  1908         -
  1909         -                set invkind [::twapi::_string_to_invkind $invkind]
  1910         -                set lhash   [::twapi::LHashValOfName $lcid $name]
  1911         -
  1912         -                if {![catch {$_typecomp Bind $name $lhash $invkind} binddata] &&
  1913         -                    [llength $binddata]} {
  1914         -                    lassign $binddata type data ifc
  1915         -                    if {$type eq "funcdesc" ||
  1916         -                        ($type eq "vardesc" && [::twapi::kl_get $data varkind] == 3)} {
  1917         -                        set params {}
  1918         -                        set bindti [::twapi::make_interface_proxy $ifc]
  1919         -                        ::twapi::trap {
  1920         -                            set params [::twapi::_resolve_params_for_prototype $bindti [::twapi::kl_get $data lprgelemdescParam]]
  1921         -                            # Param names are needed for named arguments. Index 0 is method name so skip it
  1922         -                            if {[catch {lrange [$bindti GetNames [twapi::kl_get $data memid]] 1 end} paramnames]} {
  1923         -                                set paramnames {}
  1924         -                            }
  1925         -                        } finally {
  1926         -                            $bindti Release
  1927         -                        }
  1928         -                        set proto [list [::twapi::kl_get $data memid] \
  1929         -                                       $lcid \
  1930         -                                       $invkind \
  1931         -                                       [::twapi::kl_get $data elemdescFunc.tdesc] \
  1932         -                                       $params $paramnames]
  1933         -                    } else {
  1934         -                        ::twapi::IUnknown_Release $ifc; # Don't need ifc but must release
  1935         -                        twapi::debuglog "IDispatchProxy::@Prototype: Unexpected Bind type: $type, data: $data"
  1936         -                    }
  1937         -                }
  1938         -            } onerror {} {
  1939         -                # Ignore and retry with other LCID's below
  1940         -            }
  1941         -        }
  1942         -
  1943         -
  1944         -        # If we do not have a guid return because even if we do not
  1945         -        # have a proto yet,  falling through to try another lcid will not
  1946         -        # help and in fact will cause infinite recursion.
  1947         -        
  1948         -        if {$_guid eq ""} {
  1949         -            return $proto
  1950         -        }
  1951         -
  1952         -        # We do have a guid, store the proto in cache (even if negative)
  1953         -        ::twapi::dispatch_prototype_set $_guid $name $lcid $invkind $proto
  1954         -
  1955         -        # If we have the proto return it
  1956         -        if {[llength $proto]} {
  1957         -            return $proto
  1958         -        }
  1959         -
  1960         -        # Could not find a matching prototype from the typeinfo/typecomp.
  1961         -        # We are not done yet. We will try and fall back to other lcid's
  1962         -        # Note we do this AFTER setting the prototype in the cache. That
  1963         -        # way we prevent (infinite) mutual recursion between lcid fallbacks.
  1964         -        # The fallback sequence is $lcid -> 0 -> 1033
  1965         -        # (1033 is US English). Note lcid could itself be 1033
  1966         -        # default and land up being checked twice times but that's
  1967         -        # ok since that's a one-time thing, and not very expensive either
  1968         -        # since the second go-around will hit the cache (negative). 
  1969         -        # Note the time this is really useful is when the cache has
  1970         -        # been populated explicitly from a type library since in that
  1971         -        # case many interfaces land up with a US ENglish lcid (MSI being
  1972         -        # just one example)
  1973         -
  1974         -        if {$lcid == 0} {
  1975         -            # Note this call may further recurse and return either a
  1976         -            # proto or empty (fail)
  1977         -            set proto [my @Prototype $name $invkind 1033]
  1978         -        } else {
  1979         -            set proto [my @Prototype $name $invkind 0]
  1980         -        }
  1981         -        
  1982         -        # Store it as *original* lcid.
  1983         -        ::twapi::dispatch_prototype_set $_guid $name $lcid $invkind $proto
  1984         -        
  1985         -        return $proto
  1986         -    }
  1987         -
  1988         -
  1989         -    # Initialize _typecomp and _guid. Not in constructor because may
  1990         -    # not always be required. Raises error if not available
  1991         -    method @InitTypeCompAndGuid {} {
  1992         -        my variable   _guid   _typecomp
  1993         -        
  1994         -        if {[info exists _typecomp]} {
  1995         -            # Based on code below, if _typecomp exists
  1996         -            # _guid also exists so no need to check for that
  1997         -            return
  1998         -        }
  1999         -
  2000         -        ::twapi::trap {
  2001         -            set ti [my @GetTypeInfo 0]
  2002         -        } onerror {} {
  2003         -            # We do not raise an error because
  2004         -            # even without the _typecomp we can try invoking
  2005         -            # methods via IDispatch::GetIDsOfNames
  2006         -            twapi::debuglog "Could not ITypeInfo: [twapi::trapresult]"
  2007         -            if {![info exists _guid]} {
  2008         -                # Do not overwrite if already set thru @SetGuid or constructor
  2009         -                # Set to empty otherwise so we know we tried and failed
  2010         -                set _guid ""
  2011         -            }
  2012         -            set _typecomp ""
  2013         -            return
  2014         -        }
  2015         -
  2016         -        ::twapi::trap {
  2017         -            # In case of dual interfaces, we need the typeinfo for the 
  2018         -            # dispatch. Again, errors handled in try handlers
  2019         -            switch -exact -- [::twapi::kl_get [$ti GetTypeAttr] typekind] {
  2020         -                4 {
  2021         -                    # Dispatch type, fine, just what we want
  2022         -                }
  2023         -                3 {
  2024         -                    # Interface type, Get the dispatch interface
  2025         -                    set ti2 [$ti @GetRefTypeInfo [$ti GetRefTypeOfImplType -1]]
  2026         -                    $ti Release
  2027         -                    set ti $ti2
  2028         -                }
  2029         -                default {
  2030         -                    error "Interface is not a dispatch interface"
  2031         -                }
  2032         -            }
  2033         -            if {![info exists _guid]} {
  2034         -                # _guid might have already been valid, do not overwrite
  2035         -                set _guid [::twapi::kl_get [$ti GetTypeAttr] guid]
  2036         -            }
  2037         -            set _typecomp [$ti @GetTypeComp]; # ITypeComp
  2038         -        } finally {
  2039         -            $ti Release
  2040         -        }
  2041         -    }            
  2042         -
  2043         -    # Some COM objects like MSI do not have TypeInfo interfaces from
  2044         -    # where the GUID and TypeComp can be extracted. So we allow caller
  2045         -    # to explicitly set the GUID so we can look up methods in the
  2046         -    # dispatch prototype cache if it was populated directly by the
  2047         -    # application. If guid is not a valid GUID, an attempt is made
  2048         -    # to look it up as an IID name.
  2049         -    method @SetGuid {guid} {
  2050         -        my variable _guid
  2051         -        if {$guid eq ""} {
  2052         -            if {![info exists _guid]} {
  2053         -                my @InitTypeCompAndGuid
  2054         -            }
  2055         -        } else {
  2056         -            if {![::twapi::Twapi_IsValidGUID $guid]} {
  2057         -                set resolved_guid [::twapi::name_to_iid $guid]
  2058         -                if {$resolved_guid eq ""} {
  2059         -                    error "Could not resolve $guid to a Interface GUID."
  2060         -                }
  2061         -                set guid $resolved_guid
  2062         -            }
  2063         -
  2064         -            if {[info exists _guid] && $_guid ne ""} {
  2065         -                if {[string compare -nocase $guid $_guid]} {
  2066         -                    error "Attempt to set the GUID to $guid when the dispatch proxy has already been initialized to $_guid"
  2067         -                }
  2068         -            } else {
  2069         -                set _guid $guid
  2070         -            }
  2071         -        }
  2072         -
  2073         -        return $_guid
  2074         -    }
  2075         -
  2076         -    method @GetCoClassTypeInfo {} {
  2077         -        my variable _ifc
  2078         -
  2079         -        # We can get the typeinfo for the coclass in one of two ways:
  2080         -        # If the object supports IProvideClassInfo, we use it. Else
  2081         -        # we try the following:
  2082         -        #   - from the idispatch, we get its typeinfo
  2083         -        #   - from the typeinfo, we get the containing typelib
  2084         -        #   - then we search the typelib for the coclass clsid
  2085         -
  2086         -        ::twapi::trap {
  2087         -            set pci_ifc [my QueryInterface IProvideClassInfo]
  2088         -            set ti_ifc [::twapi::IProvideClassInfo_GetClassInfo $pci_ifc]
  2089         -            return [::twapi::make_interface_proxy $ti_ifc]
  2090         -        } onerror {} {
  2091         -            # Ignore - try the longer route if we were given the coclass clsid
  2092         -        } finally {
  2093         -            if {[info exists pci_ifc]} {
  2094         -                ::twapi::IUnknown_Release $pci_ifc
  2095         -            }
  2096         -            # Note - do not do anything with ti_ifc here, EVEN on error
  2097         -        }
  2098         -
  2099         -        set co_clsid [my @Clsid]
  2100         -        if {$co_clsid eq ""} {
  2101         -            # E_FAIL
  2102         -            twapi::win32_error 0x80004005 "Could not get ITypeInfo for coclass: object does not support IProvideClassInfo and clsid not specified."
  2103         -        }
  2104         -
  2105         -        set ti [my @GetTypeInfo]
  2106         -        ::twapi::trap {
  2107         -            set tl [lindex [$ti @GetContainingTypeLib] 0]
  2108         -            if {0} {
  2109         -                $tl @Foreach -guid $co_clsid -type coclass coti {
  2110         -                    break
  2111         -                }
  2112         -                if {[info exists coti]} {
  2113         -                    return $coti
  2114         -                }
  2115         -            } else {
  2116         -                return [$tl @GetTypeInfoOfGuid $co_clsid]
  2117         -            }
  2118         -            twapi::win32_error 0x80004005 "Could not find coclass."; # E_FAIL
  2119         -        } finally {
  2120         -            if {[info exists ti]} {
  2121         -                $ti Release
  2122         -            }
  2123         -            if {[info exists tl]} {
  2124         -                $tl Release
  2125         -            }
  2126         -        }
  2127         -    }
  2128         -
  2129         -    twapi_exportall
  2130         -}
  2131         -
  2132         -
  2133         -twapi::class create ::twapi::IDispatchExProxy {
  2134         -    superclass ::twapi::IDispatchProxy
  2135         -
  2136         -    method DeleteMemberByDispID {dispid} {
  2137         -        my variable _ifc
  2138         -        return [::twapi::IDispatchEx_DeleteMemberByDispID $_ifc $dispid]
  2139         -    }
  2140         -
  2141         -    method DeleteMemberByName {name {lcid 0}} {
  2142         -        my variable _ifc
  2143         -        return [::twapi::IDispatchEx_DeleteMemberByName $_ifc $name $lcid]
  2144         -    }
  2145         -
  2146         -    method GetDispID {name flags} {
  2147         -        my variable _ifc
  2148         -        return [::twapi::IDispatchEx_GetDispID $_ifc $name $flags]
  2149         -    }
  2150         -
  2151         -    method GetMemberName {dispid} {
  2152         -        my variable _ifc
  2153         -        return [::twapi::IDispatchEx_GetMemberName $_ifc $dispid]
  2154         -    }
  2155         -
  2156         -    method GetMemberProperties {dispid flags} {
  2157         -        my variable _ifc
  2158         -        return [::twapi::IDispatchEx_GetMemberProperties $_ifc $dispid $flags]
  2159         -    }
  2160         -
  2161         -    # For some reason, order of args is different for this call!
  2162         -    method GetNextDispID {flags dispid} {
  2163         -        my variable _ifc
  2164         -        return [::twapi::IDispatchEx_GetNextDispID $_ifc $flags $dispid]
  2165         -    }
  2166         -
  2167         -    method GetNameSpaceParent {} {
  2168         -        my variable _ifc
  2169         -        return [::twapi::IDispatchEx_GetNameSpaceParent $_ifc]
  2170         -    }
  2171         -
  2172         -    method @GetNameSpaceParent {} {
  2173         -        return [::twapi::make_interface_proxy [my GetNameSpaceParent]]
  2174         -    }
  2175         -
  2176         -    method @Prototype {name invkind {lcid 0}} {
  2177         -        set invkind [::twapi::_string_to_invkind $invkind]
  2178         -
  2179         -        # First try IDispatch
  2180         -        ::twapi::trap {
  2181         -            set proto [next $name $invkind $lcid]
  2182         -            if {[llength $proto]} {
  2183         -                return $proto
  2184         -            }
  2185         -            # Note negative results ignored, as new members may be added/deleted
  2186         -            # to an IDispatchEx at any time. We will try below another way.
  2187         -
  2188         -        } onerror {} {
  2189         -            # Ignore the error - we will try below using another method
  2190         -        }
  2191         -
  2192         -        # Not a simple dispatch interface method. Could be expando
  2193         -        # type which is dynamically created. NOTE: The member is NOT
  2194         -        # created until the GetDispID call is made.
  2195         -
  2196         -        # 10 -> case insensitive, create if required
  2197         -        set dispid [my GetDispID $name 10]
  2198         -
  2199         -        # IMPORTANT : prototype retrieval results MUST NOT be cached since
  2200         -        # underlying object may add/delete members at any time.
  2201         -
  2202         -        # No type information is available for dynamic members.
  2203         -        # TBD - is that really true?
  2204         -        
  2205         -        # Invoke kind - 1 (method), 2 (propget), 4 (propput)
  2206         -        if {$invkind == 1} {
  2207         -            # method
  2208         -            set flags 0x100
  2209         -        } elseif {$invkind == 2} {
  2210         -            # propget
  2211         -            set flags 0x1
  2212         -        } elseif {$invkind == 4} {
  2213         -            # propput
  2214         -            set flags 0x4
  2215         -        } else {
  2216         -            # TBD - what about putref (flags 0x10)
  2217         -            error "Internal error: Invalid invkind value $invkind"
  2218         -        }
  2219         -
  2220         -        # Try at least getting the invocation type but even that is not
  2221         -        # supported by all objects in which case we assume it can be invoked.
  2222         -        # TBD - in that case, why even bother doing GetMemberProperties?
  2223         -        if {! [catch {
  2224         -            set flags [expr {[my GetMemberProperties 0x115] & $flags}]
  2225         -        }]} {
  2226         -            if {! $flags} {
  2227         -                return {};      # EMpty proto -> no valid name for this invkind
  2228         -            }
  2229         -        }
  2230         -
  2231         -        # Valid invkind or object does not support GetMemberProperties
  2232         -        # Return type is 8 (BSTR) but does not really matter as 
  2233         -        # actual type will be set based on what is returned.
  2234         -        return [list $dispid $lcid $invkind 8]
  2235         -    }
  2236         -
  2237         -    twapi_exportall
  2238         -}
  2239         -
  2240         -
  2241         -# ITypeInfo 
  2242         -#-----------
  2243         -
  2244         -twapi::class create ::twapi::ITypeInfoProxy {
  2245         -    superclass ::twapi::IUnknownProxy
  2246         -
  2247         -    method GetRefTypeOfImplType {index} {
  2248         -        my variable _ifc
  2249         -        return [::twapi::ITypeInfo_GetRefTypeOfImplType $_ifc $index]
  2250         -    }
  2251         -
  2252         -    method GetDocumentation {memid} {
  2253         -        my variable _ifc
  2254         -        return [::twapi::ITypeInfo_GetDocumentation $_ifc $memid]
  2255         -    }
  2256         -
  2257         -    method GetImplTypeFlags {index} {
  2258         -        my variable _ifc
  2259         -        return [::twapi::ITypeInfo_GetImplTypeFlags $_ifc $index]
  2260         -    }
  2261         -
  2262         -    method GetNames {index} {
  2263         -        my variable _ifc
  2264         -        return [::twapi::ITypeInfo_GetNames $_ifc $index]
  2265         -    }
  2266         -
  2267         -    method GetTypeAttr {} {
  2268         -        my variable _ifc
  2269         -        return [::twapi::ITypeInfo_GetTypeAttr $_ifc]
  2270         -    }
  2271         -
  2272         -    method GetFuncDesc {index} {
  2273         -        my variable _ifc
  2274         -        return [::twapi::ITypeInfo_GetFuncDesc $_ifc $index]
  2275         -    }
  2276         -
  2277         -    method GetVarDesc {index} {
  2278         -        my variable _ifc
  2279         -        return [::twapi::ITypeInfo_GetVarDesc $_ifc $index]
  2280         -    }
  2281         -
  2282         -    method GetIDsOfNames {names} {
  2283         -        my variable _ifc
  2284         -        return [::twapi::ITypeInfo_GetIDsOfNames $_ifc $names]
  2285         -    }
  2286         -
  2287         -    method GetRefTypeInfo {hreftype} {
  2288         -        my variable _ifc
  2289         -        return [::twapi::ITypeInfo_GetRefTypeInfo $_ifc $hreftype]
  2290         -    }
  2291         -
  2292         -    method @GetRefTypeInfo {hreftype} {
  2293         -        return [::twapi::make_interface_proxy [my GetRefTypeInfo $hreftype]]
  2294         -    }
  2295         -
  2296         -    method GetTypeComp {} {
  2297         -        my variable _ifc
  2298         -        return [::twapi::ITypeInfo_GetTypeComp $_ifc]
  2299         -    }
  2300         -
  2301         -    method @GetTypeComp {} {
  2302         -        return [::twapi::make_interface_proxy [my GetTypeComp]]
  2303         -    }
  2304         -
  2305         -    method GetContainingTypeLib {} {
  2306         -        my variable _ifc
  2307         -        return [::twapi::ITypeInfo_GetContainingTypeLib $_ifc]
  2308         -    }
  2309         -
  2310         -    method @GetContainingTypeLib {} {
  2311         -        lassign [my GetContainingTypeLib] itypelib index
  2312         -        return [list [::twapi::make_interface_proxy $itypelib] $index]
  2313         -    }
  2314         -
  2315         -    method @GetRefTypeInfoFromIndex {index} {
  2316         -        return [my @GetRefTypeInfo [my GetRefTypeOfImplType $index]]
  2317         -    }
  2318         -
  2319         -    # Friendlier version of GetTypeAttr
  2320         -    method @GetTypeAttr {args} {
  2321         -
  2322         -        array set opts [::twapi::parseargs args {
  2323         -            all
  2324         -            guid
  2325         -            lcid
  2326         -            constructorid
  2327         -            destructorid
  2328         -            schema
  2329         -            instancesize
  2330         -            typekind
  2331         -            fncount
  2332         -            varcount
  2333         -            interfacecount
  2334         -            vtblsize
  2335         -            alignment
  2336         -            majorversion
  2337         -            minorversion
  2338         -            aliasdesc
  2339         -            flags
  2340         -            idldesc
  2341         -            memidmap
  2342         -        } -maxleftover 0]
  2343         -
  2344         -        array set data [my GetTypeAttr]
  2345         -        set result [list ]
  2346         -        foreach {opt key} {
  2347         -            guid guid
  2348         -            lcid lcid
  2349         -            constructorid memidConstructor
  2350         -            destructorid  memidDestructor
  2351         -            schema lpstrSchema
  2352         -            instancesize cbSizeInstance
  2353         -            fncount cFuncs
  2354         -            varcount cVars
  2355         -            interfacecount cImplTypes
  2356         -            vtblsize cbSizeVft
  2357         -            alignment cbAlignment
  2358         -            majorversion wMajorVerNum
  2359         -            minorversion wMinorVerNum
  2360         -            aliasdesc tdescAlias
  2361         -        } {
  2362         -            if {$opts(all) || $opts($opt)} {
  2363         -                lappend result -$opt $data($key)
  2364         -            }
  2365         -        }
  2366         -
  2367         -        if {$opts(all) || $opts(typekind)} {
  2368         -            set typekind $data(typekind)
  2369         -            if {[info exists ::twapi::_typekind_map($typekind)]} {
  2370         -                set typekind $::twapi::_typekind_map($typekind)
  2371         -            }
  2372         -            lappend result -typekind $typekind
  2373         -        }
  2374         -
  2375         -        if {$opts(all) || $opts(flags)} {
  2376         -            lappend result -flags [::twapi::_make_symbolic_bitmask $data(wTypeFlags) {
  2377         -                appobject       1
  2378         -                cancreate       2
  2379         -                licensed        4
  2380         -                predeclid       8
  2381         -                hidden         16
  2382         -                control        32
  2383         -                dual           64
  2384         -                nonextensible 128
  2385         -                oleautomation 256
  2386         -                restricted    512
  2387         -                aggregatable 1024
  2388         -                replaceable  2048
  2389         -                dispatchable 4096
  2390         -                reversebind  8192
  2391         -                proxy       16384
  2392         -            }]
  2393         -        }
  2394         -
  2395         -        if {$opts(all) || $opts(idldesc)} {
  2396         -            lappend result -idldesc [::twapi::_make_symbolic_bitmask $data(idldescType) {
  2397         -                in 1
  2398         -                out 2
  2399         -                lcid 4
  2400         -                retval 8
  2401         -            }]
  2402         -        }
  2403         -
  2404         -        if {$opts(all) || $opts(memidmap)} {
  2405         -            set memidmap [list ]
  2406         -            for {set i 0} {$i < $data(cFuncs)} {incr i} {
  2407         -                array set fninfo [my @GetFuncDesc $i -memid -name]
  2408         -                lappend memidmap $fninfo(-memid) $fninfo(-name)
  2409         -            }
  2410         -            lappend result -memidmap $memidmap
  2411         -        }
  2412         -
  2413         -        return $result
  2414         -    }
  2415         -
  2416         -    #
  2417         -    # Get a variable description associated with a type
  2418         -    method @GetVarDesc {index args} {
  2419         -        # TBD - add support for retrieving elemdescVar.paramdesc fields
  2420         -
  2421         -        array set opts [::twapi::parseargs args {
  2422         -            all
  2423         -            name
  2424         -            memid
  2425         -            schema
  2426         -            datatype
  2427         -            value
  2428         -            valuetype
  2429         -            varkind
  2430         -            flags
  2431         -        } -maxleftover 0]
  2432         -
  2433         -        array set data [my GetVarDesc $index]
  2434         -        
  2435         -        set result [list ]
  2436         -        foreach {opt key} {
  2437         -            memid memid
  2438         -            schema lpstrSchema
  2439         -            datatype elemdescVar.tdesc
  2440         -        } {
  2441         -            if {$opts(all) || $opts($opt)} {
  2442         -                lappend result -$opt $data($key)
  2443         -            }
  2444         -        }
  2445         -
  2446         -
  2447         -        if {$opts(all) || $opts(value)} {
  2448         -            if {[info exists data(lpvarValue)]} {
  2449         -                # Const value
  2450         -                lappend result -value [lindex $data(lpvarValue) 1]
  2451         -            } else {
  2452         -                lappend result -value $data(oInst)
  2453         -            }
  2454         -        }
  2455         -
  2456         -        if {$opts(all) || $opts(valuetype)} {
  2457         -            if {[info exists data(lpvarValue)]} {
  2458         -                lappend result -valuetype [lindex $data(lpvarValue) 0]
  2459         -            } else {
  2460         -                lappend result -valuetype int
  2461         -            }
  2462         -        }
  2463         -
  2464         -        if {$opts(all) || $opts(varkind)} {
  2465         -            lappend result -varkind [::twapi::kl_get {
  2466         -                0 perinstance
  2467         -                1 static
  2468         -                2 const
  2469         -                3 dispatch
  2470         -            } $data(varkind) $data(varkind)]
  2471         -        }
  2472         -
  2473         -        if {$opts(all) || $opts(flags)} {
  2474         -            lappend result -flags [::twapi::_make_symbolic_bitmask $data(wVarFlags) {
  2475         -                readonly       1
  2476         -                source       2
  2477         -                bindable        4
  2478         -                requestedit       8
  2479         -                displaybind         16
  2480         -                defaultbind        32
  2481         -                hidden           64
  2482         -                restricted 128
  2483         -                defaultcollelem 256
  2484         -                uidefault    512
  2485         -                nonbrowsable 1024
  2486         -                replaceable  2048
  2487         -                immediatebind 4096
  2488         -            }]
  2489         -        }
  2490         -        
  2491         -        if {$opts(all) || $opts(name)} {
  2492         -            set result [concat $result [my @GetDocumentation $data(memid) -name]]
  2493         -        }    
  2494         -
  2495         -        return $result
  2496         -    }
  2497         -
  2498         -    method @GetFuncDesc {index args} {
  2499         -        array set opts [::twapi::parseargs args {
  2500         -            all
  2501         -            name
  2502         -            memid
  2503         -            funckind
  2504         -            invkind
  2505         -            callconv
  2506         -            params
  2507         -            paramnames
  2508         -            flags
  2509         -            datatype
  2510         -            resultcodes
  2511         -            vtbloffset
  2512         -        } -maxleftover 0]
  2513         -
  2514         -        array set data [my GetFuncDesc $index]
  2515         -        set result [list ]
  2516         -
  2517         -        if {$opts(all) || $opts(paramnames)} {
  2518         -            lappend result -paramnames [lrange [my GetNames $data(memid)] 1 end]
  2519         -        }
  2520         -        foreach {opt key} {
  2521         -            memid       memid
  2522         -            vtbloffset  oVft
  2523         -            datatype    elemdescFunc.tdesc
  2524         -            resultcodes lprgscode
  2525         -        } {
  2526         -            if {$opts(all) || $opts($opt)} {
  2527         -                lappend result -$opt $data($key)
  2528         -            }
  2529         -        }
  2530         -
  2531         -        if {$opts(all) || $opts(funckind)} {
  2532         -            lappend result -funckind [::twapi::kl_get {
  2533         -                0 virtual
  2534         -                1 purevirtual
  2535         -                2 nonvirtual
  2536         -                3 static
  2537         -                4 dispatch
  2538         -            } $data(funckind) $data(funckind)]
  2539         -        }
  2540         -
  2541         -        if {$opts(all) || $opts(invkind)} {
  2542         -            lappend result -invkind [::twapi::_string_to_invkind $data(invkind)]
  2543         -        }
  2544         -
  2545         -        if {$opts(all) || $opts(callconv)} {
  2546         -            lappend result -callconv [::twapi::kl_get {
  2547         -                0 fastcall
  2548         -                1 cdecl
  2549         -                2 pascal
  2550         -                3 macpascal
  2551         -                4 stdcall
  2552         -                5 fpfastcall
  2553         -                6 syscall
  2554         -                7 mpwcdecl
  2555         -                8 mpwpascal
  2556         -            } $data(callconv) $data(callconv)]
  2557         -        }
  2558         -
  2559         -        if {$opts(all) || $opts(flags)} {
  2560         -            lappend result -flags [::twapi::_make_symbolic_bitmask $data(wFuncFlags) {
  2561         -                restricted   1
  2562         -                source       2
  2563         -                bindable     4
  2564         -                requestedit  8
  2565         -                displaybind  16
  2566         -                defaultbind  32
  2567         -                hidden       64
  2568         -                usesgetlasterror  128
  2569         -                defaultcollelem 256
  2570         -                uidefault    512
  2571         -                nonbrowsable 1024
  2572         -                replaceable  2048
  2573         -                immediatebind 4096
  2574         -            }]
  2575         -        }
  2576         -
  2577         -        if {$opts(all) || $opts(params)} {
  2578         -            set params [list ]
  2579         -            foreach param $data(lprgelemdescParam) {
  2580         -                lassign $param paramtype paramdesc
  2581         -                set paramflags [::twapi::_paramflags_to_tokens [lindex $paramdesc 0]]
  2582         -                if {[llength $paramdesc] > 1} {
  2583         -                    # There is a default value associated with the parameter
  2584         -                    lappend params [list $paramtype $paramflags [lindex $paramdesc 1]]
  2585         -                } else {
  2586         -                    lappend params [list $paramtype $paramflags]
  2587         -                }
  2588         -            }
  2589         -            lappend result -params $params
  2590         -        }
  2591         -
  2592         -        if {$opts(all) || $opts(name)} {
  2593         -            set result [concat $result [my @GetDocumentation $data(memid) -name]]
  2594         -        }    
  2595         -
  2596         -        return $result
  2597         -    }
  2598         -
  2599         -    #
  2600         -    # Get documentation for a element of a type
  2601         -    method @GetDocumentation {memid args} {
  2602         -        array set opts [::twapi::parseargs args {
  2603         -            all
  2604         -            name
  2605         -            docstring
  2606         -            helpctx
  2607         -            helpfile
  2608         -        } -maxleftover 0]
  2609         -
  2610         -        lassign [my GetDocumentation $memid] name docstring helpctx helpfile
  2611         -
  2612         -        set result [list ]
  2613         -        foreach opt {name docstring helpctx helpfile} {
  2614         -            if {$opts(all) || $opts($opt)} {
  2615         -                lappend result -$opt [set $opt]
  2616         -            }
  2617         -        }
  2618         -        return $result
  2619         -    }
  2620         -
  2621         -    method @GetName {{memid -1}} {
  2622         -        return [lindex [my @GetDocumentation $memid -name] 1]
  2623         -    }
  2624         -
  2625         -    method @GetImplTypeFlags {index} {
  2626         -        return [::twapi::_make_symbolic_bitmask \
  2627         -                    [my GetImplTypeFlags $index] \
  2628         -                    {
  2629         -                        default      1
  2630         -                        source       2
  2631         -                        restricted   4
  2632         -                        defaultvtable 8
  2633         -                    }]  
  2634         -    }
  2635         -
  2636         -    #
  2637         -    # Get the typeinfo for the default source interface of a coclass
  2638         -    # This object must be the typeinfo of the coclass
  2639         -    method @GetDefaultSourceTypeInfo {} {
  2640         -        set count [lindex [my @GetTypeAttr -interfacecount] 1]
  2641         -        for {set i 0} {$i < $count} {incr i} {
  2642         -            set flags [my GetImplTypeFlags $i]
  2643         -            # default 0x1, source 0x2
  2644         -            if {($flags & 3) == 3} {
  2645         -                # Our source interface implementation can only handle IDispatch
  2646         -                # so check if the source interface is that else keep looking.
  2647         -                # We even ignore dual interfaces because we cannot then
  2648         -                # assume caller will use the dispatch version
  2649         -                set ti [my @GetRefTypeInfoFromIndex $i]
  2650         -                array set typeinfo [$ti GetTypeAttr]
  2651         -                # typekind == 4 -> IDispatch,
  2652         -                # flags - 0x1000 -> dispatchable, 0x40 -> dual
  2653         -                if {$typeinfo(typekind) == 4 &&
  2654         -                    ($typeinfo(wTypeFlags) & 0x1000) &&
  2655         -                    !($typeinfo(wTypeFlags) & 0x40)} {
  2656         -                    return $ti
  2657         -                }
  2658         -                $ti destroy
  2659         -            }
  2660         -        }
  2661         -        return ""
  2662         -    }
  2663         -
  2664         -    twapi_exportall
  2665         -}
  2666         -
  2667         -
  2668         -# ITypeLib
  2669         -#----------
  2670         -
  2671         -twapi::class create ::twapi::ITypeLibProxy {
  2672         -    superclass ::twapi::IUnknownProxy
  2673         -
  2674         -    method GetDocumentation {index} {
  2675         -        my variable _ifc
  2676         -        return [::twapi::ITypeLib_GetDocumentation $_ifc $index]
  2677         -    }
  2678         -    method GetTypeInfoCount {} {
  2679         -        my variable _ifc
  2680         -        return [::twapi::ITypeLib_GetTypeInfoCount $_ifc]
  2681         -    }
  2682         -    method GetTypeInfoType {index} {
  2683         -        my variable _ifc
  2684         -        return [::twapi::ITypeLib_GetTypeInfoType $_ifc $index]
  2685         -    }
  2686         -    method GetLibAttr {} {
  2687         -        my variable _ifc
  2688         -        return [::twapi::ITypeLib_GetLibAttr $_ifc]
  2689         -    }
  2690         -    method GetTypeInfo {index} {
  2691         -        my variable _ifc
  2692         -        return [::twapi::ITypeLib_GetTypeInfo $_ifc $index]
  2693         -    }
  2694         -    method @GetTypeInfo {index} {
  2695         -        return [::twapi::make_interface_proxy [my GetTypeInfo $index]]
  2696         -    }
  2697         -    method GetTypeInfoOfGuid {guid} {
  2698         -        my variable _ifc
  2699         -        return [::twapi::ITypeLib_GetTypeInfoOfGuid $_ifc $guid]
  2700         -    }
  2701         -    method @GetTypeInfoOfGuid {guid} {
  2702         -        return [::twapi::make_interface_proxy [my GetTypeInfoOfGuid $guid]]
  2703         -    }
  2704         -    method @GetTypeInfoType {index} {
  2705         -        set typekind [my GetTypeInfoType $index]
  2706         -        if {[info exists ::twapi::_typekind_map($typekind)]} {
  2707         -            set typekind $::twapi::_typekind_map($typekind)
  2708         -        }
  2709         -        return $typekind
  2710         -    }
  2711         -
  2712         -    method @GetDocumentation {id args} {
  2713         -        array set opts [::twapi::parseargs args {
  2714         -            all
  2715         -            name
  2716         -            docstring
  2717         -            helpctx
  2718         -            helpfile
  2719         -        } -maxleftover 0]
  2720         -
  2721         -        lassign [my GetDocumentation $id] name docstring helpctx helpfile
  2722         -        set result [list ]
  2723         -        foreach opt {name docstring helpctx helpfile} {
  2724         -            if {$opts(all) || $opts($opt)} {
  2725         -                lappend result -$opt [set $opt]
  2726         -            }
  2727         -        }
  2728         -        return $result
  2729         -    }
  2730         -
  2731         -    method @GetName {} {
  2732         -        return [lindex [my GetDocumentation -1] 0]
  2733         -    }
  2734         -
  2735         -    method @GetLibAttr {args} {
  2736         -        array set opts [::twapi::parseargs args {
  2737         -            all
  2738         -            guid
  2739         -            lcid
  2740         -            syskind
  2741         -            majorversion
  2742         -            minorversion
  2743         -            flags
  2744         -        } -maxleftover 0]
  2745         -
  2746         -        array set data [my GetLibAttr]
  2747         -        set result [list ]
  2748         -        foreach {opt key} {
  2749         -            guid guid
  2750         -            lcid lcid
  2751         -            majorversion wMajorVerNum
  2752         -            minorversion wMinorVerNum
  2753         -        } {
  2754         -            if {$opts(all) || $opts($opt)} {
  2755         -                lappend result -$opt $data($key)
  2756         -            }
  2757         -        }
  2758         -
  2759         -        if {$opts(all) || $opts(flags)} {
  2760         -            lappend result -flags [::twapi::_make_symbolic_bitmask $data(wLibFlags) {
  2761         -                restricted      1
  2762         -                control         2
  2763         -                hidden          4
  2764         -                hasdiskimage    8
  2765         -            }]
  2766         -        }
  2767         -
  2768         -        if {$opts(all) || $opts(syskind)} {
  2769         -            lappend result -syskind [::twapi::kl_get {
  2770         -                0 win16
  2771         -                1 win32
  2772         -                2 mac
  2773         -            } $data(syskind) $data(syskind)]
  2774         -        }
  2775         -
  2776         -        return $result
  2777         -    }
  2778         -
  2779         -    #
  2780         -    # Iterate through a typelib. Caller is responsible for releasing
  2781         -    # each ITypeInfo passed to it
  2782         -    # 
  2783         -    method @Foreach {args} {
  2784         -
  2785         -        array set opts [::twapi::parseargs args {
  2786         -            type.arg
  2787         -            name.arg
  2788         -            guid.arg
  2789         -        } -maxleftover 2 -nulldefault]
  2790         -
  2791         -        if {[llength $args] != 2} {
  2792         -            error "Syntax error: Should be '[self] @Foreach ?options? VARNAME SCRIPT'"
  2793         -        }
  2794         -
  2795         -        lassign $args varname script
  2796         -        upvar $varname varti
  2797         -
  2798         -        set count [my GetTypeInfoCount]
  2799         -        for {set i 0} {$i < $count} {incr i} {
  2800         -            if {$opts(type) ne "" && $opts(type) ne [my @GetTypeInfoType $i]} {
  2801         -                continue;                   # Type does not match
  2802         -            }
  2803         -            if {$opts(name) ne "" &&
  2804         -                [string compare -nocase $opts(name) [lindex [my @GetDocumentation $i -name] 1]]} {
  2805         -                continue;                   # Name does not match
  2806         -            }
  2807         -            set ti [my @GetTypeInfo $i]
  2808         -            if {$opts(guid) ne ""} {
  2809         -                if {[string compare -nocase [lindex [$ti @GetTypeAttr -guid] 1] $opts(guid)]} {
  2810         -                    $ti Release
  2811         -                    continue
  2812         -                }
  2813         -            }
  2814         -            set varti $ti
  2815         -            set ret [catch {uplevel 1 $script} result]
  2816         -            switch -exact -- $ret {
  2817         -                1 {
  2818         -                    error $result $::errorInfo $::errorCode
  2819         -                }
  2820         -                2 {
  2821         -                    return -code return $result; # TCL_RETURN
  2822         -                }
  2823         -                3 {
  2824         -                    set i $count; # TCL_BREAK
  2825         -                }
  2826         -            }
  2827         -        }
  2828         -        return
  2829         -    }
  2830         -
  2831         -    method @Register {path {helppath ""}} {
  2832         -        my variable _ifc
  2833         -        ::twapi::RegisterTypeLib $_ifc $path $helppath
  2834         -    }
  2835         -
  2836         -    method @LoadDispatchPrototypes {} {
  2837         -        set data [my @Read -type dispatch]
  2838         -        if {![dict exists $data dispatch]} {
  2839         -            return
  2840         -        }
  2841         -
  2842         -        dict for {guid guiddata} [dict get $data dispatch] {
  2843         -            foreach type {methods properties} {
  2844         -                if {[dict exists $guiddata -$type]} {
  2845         -                    dict for {name namedata} [dict get $guiddata -$type] {
  2846         -                        dict for {lcid lciddata} $namedata {
  2847         -                            dict for {invkind proto} $lciddata {
  2848         -                                ::twapi::dispatch_prototype_set \
  2849         -                                    $guid $name $lcid $invkind $proto
  2850         -                            }
  2851         -                        }
  2852         -                    }
  2853         -                }
  2854         -            }
  2855         -        }
  2856         -    }
  2857         -
  2858         -    method @Text {args} {
  2859         -        array set opts [::twapi::parseargs args {
  2860         -            type.arg
  2861         -            name.arg
  2862         -        } -maxleftover 0 -nulldefault]
  2863         -
  2864         -        set text {}
  2865         -        my @Foreach -type $opts(type) -name $opts(name) ti {
  2866         -            ::twapi::trap {
  2867         -                array set attrs [$ti @GetTypeAttr -all]
  2868         -                set docs [$ti @GetDocumentation -1 -name -docstring]
  2869         -                set desc "[string totitle $attrs(-typekind)] [::twapi::kl_get $docs -name] $attrs(-guid) - [::twapi::kl_get $docs -docstring]\n"
  2870         -                switch -exact -- $attrs(-typekind) {
  2871         -                    record -
  2872         -                    union  -
  2873         -                    enum {
  2874         -                        for {set j 0} {$j < $attrs(-varcount)} {incr j} {
  2875         -                            array set vardata [$ti @GetVarDesc $j -all]
  2876         -                            set vardesc "$vardata(-varkind) [::twapi::_resolve_com_type_text $ti $vardata(-datatype)] $vardata(-name)"
  2877         -                            if {$attrs(-typekind) eq "enum"} {
  2878         -                                append vardesc " = $vardata(-value) ([::twapi::_resolve_com_type_text $ti $vardata(-valuetype)])"
  2879         -                            } else {
  2880         -                                append vardesc " (offset $vardata(-value))"
  2881         -                            }
  2882         -                            append desc "\t$vardesc\n"
  2883         -                        }
  2884         -                    }
  2885         -                    alias {
  2886         -                        append desc "\ttypedef $attrs(-aliasdesc)\n"
  2887         -                    }
  2888         -                    module -
  2889         -                    dispatch -
  2890         -                    interface {
  2891         -                        append desc [::twapi::_interface_text $ti]
  2892         -                    }
  2893         -                    coclass {
  2894         -                        for {set j 0} {$j < $attrs(-interfacecount)} {incr j} {
  2895         -                            set ti2 [$ti @GetRefTypeInfoFromIndex $j]
  2896         -                            set idesc [$ti2 @GetName]
  2897         -                            set iflags [$ti @GetImplTypeFlags $j]
  2898         -                            if {[llength $iflags]} {
  2899         -                                append idesc " ([join $iflags ,])"
  2900         -                            }
  2901         -                            append desc \t$idesc
  2902         -                            $ti2 Release
  2903         -                            unset ti2
  2904         -                        }
  2905         -                    }
  2906         -                    default {
  2907         -                        append desc "Unknown typekind: $attrs(-typekind)\n"
  2908         -                    }
  2909         -                }
  2910         -                append text \n$desc
  2911         -            } finally {
  2912         -                $ti Release
  2913         -                if {[info exists ti2]} {
  2914         -                    $ti2 Release
  2915         -                }
  2916         -            }
  2917         -        }
  2918         -        return $text
  2919         -    }
  2920         -
  2921         -    method @GenerateCode {args} {
  2922         -        array set opts [twapi::parseargs args {
  2923         -            namespace.arg
  2924         -        } -ignoreunknown]
  2925         -
  2926         -        if {![info exists opts(namespace)]} {
  2927         -            set opts(namespace) [string tolower [my @GetName]]
  2928         -        }
  2929         -
  2930         -        set data [my @Read {*}$args]
  2931         -        
  2932         -        set code {}
  2933         -        if {[dict exists $data dispatch]} {
  2934         -            dict for {guid guiddata} [dict get $data dispatch] {
  2935         -                set dispatch_name [dict get $guiddata -name]
  2936         -                append code "\n# Dispatch Interface $dispatch_name\n"
  2937         -                foreach type {methods properties} {
  2938         -                    if {[dict exists $guiddata -$type]} {
  2939         -                        append code "# $dispatch_name [string totitle $type]\n"
  2940         -                        dict for {name namedata} [dict get $guiddata -$type] {
  2941         -                            dict for {lcid lciddata} $namedata {
  2942         -                                dict for {invkind proto} $lciddata {
  2943         -                                    append code [list ::twapi::dispatch_prototype_set \
  2944         -                                                     $guid $name $lcid $invkind $proto]
  2945         -                                    append code \n
  2946         -                                }
  2947         -                            }
  2948         -                        }
  2949         -                    }
  2950         -                }
  2951         -            }
  2952         -        }
  2953         -
  2954         -        # If namespace specfied as empty string (as opposed to unspecified)
  2955         -        # do not output a namespace
  2956         -        if {$opts(namespace) ne "" &&
  2957         -            ([dict exists $data enum] ||
  2958         -             [dict exists $data module] ||
  2959         -             [dict exists $data coclass])
  2960         -        } {
  2961         -            append code "\nnamespace eval $opts(namespace) \{"
  2962         -            append code \n
  2963         -        }
  2964         -
  2965         -        if {[dict exists $data module]} {
  2966         -            dict for {guid guiddata} [dict get $data module] {
  2967         -                # Some modules may not have constants (-values).
  2968         -                # We currently only output constants from modules, not functions
  2969         -                if {[dict exists $guiddata -values]} {
  2970         -                    set module_name [dict get $guiddata -name]
  2971         -                    append code "\n    # Module $module_name ($guid)\n"
  2972         -                    append code "    [list array set $module_name [dict get $guiddata -values]]"
  2973         -                    append code \n
  2974         -                }
  2975         -            }
  2976         -        }
  2977         -
  2978         -        if {[dict exists $data enum]} {
  2979         -            dict for {name def} [dict get $data enum] {
  2980         -                append code "\n    # Enum $name\n"
  2981         -                append code "    [list array set $name [dict get $def -values]]"
  2982         -                append code \n
  2983         -            }
  2984         -        }
  2985         -
  2986         -        if {[dict exists $data coclass]} {
  2987         -            dict for {guid def} [dict get $data coclass] {
  2988         -                append code "\n    # Coclass [dict get $def -name]"
  2989         -                # Look for the default interface so we can remember its GUID.
  2990         -                # This is necessary for the cases where the Dispatch interface
  2991         -                # GUID is not available via a TypeInfo interface (e.g.
  2992         -                # a 64-bit COM component not registered with the 32-bit
  2993         -                # COM registry)
  2994         -                set default_dispatch_guid ""
  2995         -                if {[dict exists $def -interfaces]} {
  2996         -                    dict for {ifc_guid ifc_def} [dict get $def -interfaces] {
  2997         -                        if {[dict exists $data dispatch $ifc_guid]} {
  2998         -                            # Yes it is a dispatch interface
  2999         -                            # Make sure it is marked as default interface
  3000         -                            if {[dict exists $ifc_def -flags] &&
  3001         -                                [dict get $ifc_def -flags] == 1} {
  3002         -                                set default_dispatch_guid $ifc_guid
  3003         -                                break
  3004         -                            }
  3005         -                        }
  3006         -                    }
  3007         -                }
  3008         -                
  3009         -                # We assume here that coclass has a default interface
  3010         -                # which is dispatchable. Else an error will be generated
  3011         -                # at runtime.
  3012         -                append code [format {
  3013         -    twapi::class create %1$s {
  3014         -        superclass ::twapi::Automation
  3015         -        constructor {args} {
  3016         -            set ifc [twapi::com_create_instance "%2$s" -interface IDispatch -raw {*}$args]
  3017         -            next [twapi::IDispatchProxy new $ifc "%2$s"]
  3018         -            if {[string length "%3$s"]} {
  3019         -                my -interfaceguid "%3$s"
  3020         -            }
  3021         -        }
  3022         -    }} [dict get $def -name] $guid $default_dispatch_guid]
  3023         -                append code \n
  3024         -            }
  3025         -        }
  3026         -
  3027         -        if {$opts(namespace) ne "" &&
  3028         -            ([dict exists $data enum] ||
  3029         -             [dict exists $data module] ||
  3030         -             [dict exists $data coclass])
  3031         -        } {
  3032         -            append code "\}"
  3033         -            append code \n
  3034         -        }
  3035         -
  3036         -
  3037         -        return $code
  3038         -    }
  3039         -
  3040         -    method @Read {args} {
  3041         -        array set opts [::twapi::parseargs args {
  3042         -            type.arg
  3043         -            name.arg
  3044         -        } -maxleftover 0 -nulldefault]
  3045         -
  3046         -        set data [dict create]
  3047         -        my @Foreach -type $opts(type) -name $opts(name) ti {
  3048         -            ::twapi::trap {
  3049         -                array set attrs [$ti @GetTypeAttr -guid -lcid -varcount -fncount -interfacecount -typekind]
  3050         -                set name [lindex [$ti @GetDocumentation -1 -name] 1]
  3051         -                # dict set data $attrs(-typekind) $name {}
  3052         -                switch -exact -- $attrs(-typekind) {
  3053         -                    record -
  3054         -                    union  -
  3055         -                    enum {
  3056         -                        # For consistency with the coclass and dispatch dict structure
  3057         -                        # we have a separate key for 'name' even though it is the same
  3058         -                        # as the dict key
  3059         -                        dict set data $attrs(-typekind) $name -name $name
  3060         -                        for {set j 0} {$j < $attrs(-varcount)} {incr j} {
  3061         -                            array set vardata [$ti @GetVarDesc $j -name -value]
  3062         -                            dict set data $attrs(-typekind) $name -values $vardata(-name) $vardata(-value)
  3063         -                        }
  3064         -                    }
  3065         -                    alias {
  3066         -                        # TBD - anything worth importing ?
  3067         -                    }
  3068         -                    dispatch {
  3069         -                        # Load up the functions
  3070         -                        dict set data $attrs(-typekind) $attrs(-guid) -name $name
  3071         -                        for {set j 0} {$j < $attrs(-fncount)} {incr j} {
  3072         -                            array set funcdata [$ti GetFuncDesc $j]
  3073         -                            if {$funcdata(funckind) != 4} {
  3074         -                                # Not a dispatch function (4), ignore
  3075         -                                # TBD - what else could it be if already filtering
  3076         -                                # typeinfo on dispatch
  3077         -                                # Vtable set funckind "(vtable $funcdata(-oVft))"
  3078         -                                ::twapi::debuglog "Unexpected funckind value '$funcdata(funckind)' ignored. funcdata: [array get funcdata]"
  3079         -                                continue;
  3080         -                            }
  3081         -                            
  3082         -                            set proto [list $funcdata(memid) \
  3083         -                                           $attrs(-lcid) \
  3084         -                                           $funcdata(invkind) \
  3085         -                                           $funcdata(elemdescFunc.tdesc) \
  3086         -                                           [::twapi::_resolve_params_for_prototype $ti $funcdata(lprgelemdescParam)]]
  3087         -                            # Param names are needed for named arguments. Index 0 is method name so skip it
  3088         -                            if {[catch {lappend proto [lrange [$ti GetNames $funcdata(memid)] 1 end]}]} {
  3089         -                                # Could not get param names
  3090         -                                lappend proto {}
  3091         -                            }
  3092         -
  3093         -                            dict set data "$attrs(-typekind)" \
  3094         -                                $attrs(-guid) \
  3095         -                                -methods \
  3096         -                                [$ti @GetName $funcdata(memid)] \
  3097         -                                $attrs(-lcid) \
  3098         -                                $funcdata(invkind) \
  3099         -                                $proto
  3100         -                        }
  3101         -                        # Load up the properties
  3102         -                        for {set j 0} {$j < $attrs(-varcount)} {incr j} {
  3103         -                            array set vardata [$ti GetVarDesc $j]
  3104         -                            # We will add both propput and propget.
  3105         -                            # propget:
  3106         -                            dict set data "$attrs(-typekind)" \
  3107         -                                $attrs(-guid) \
  3108         -                                -properties \
  3109         -                                [$ti @GetName $vardata(memid)] \
  3110         -                                $attrs(-lcid) \
  3111         -                                2 \
  3112         -                                [list $vardata(memid) $attrs(-lcid) 2 $vardata(elemdescVar.tdesc) {} {}]
  3113         -
  3114         -                            # TBD - mock up the parameters for the property set
  3115         -                            # Single parameter corresponding to return type of
  3116         -                            # property. Param list is of the form
  3117         -                            # {PARAM1 PARAM2} where PARAM is {TYPE {FLAGS ?DEFAULT}}
  3118         -                            # So param list with one param is
  3119         -                            # {{TYPE {FLAGS ?DEFAULT?}}}
  3120         -                            # propput:
  3121         -                            if {! ($vardata(wVarFlags) & 1)} {
  3122         -                                # Not read-only
  3123         -                                dict set data "$attrs(-typekind)" \
  3124         -                                    $attrs(-guid) \
  3125         -                                    -properties \
  3126         -                                    [$ti @GetName $vardata(memid)] \
  3127         -                                    $attrs(-lcid) \
  3128         -                                    4 \
  3129         -                                    [list $vardata(memid) $attrs(-lcid) 4 24 [list [list $vardata(elemdescVar.tdesc) [list 1]]] {}]
  3130         -                            }
  3131         -                        }
  3132         -                    }
  3133         -
  3134         -
  3135         -                    module {
  3136         -                        dict set data $attrs(-typekind) $attrs(-guid) -name $name
  3137         -                        # TBD - Load up the functions
  3138         -
  3139         -                        # Now load up the variables
  3140         -                        for {set j 0} {$j < $attrs(-varcount)} {incr j} {
  3141         -                            array set vardata [$ti @GetVarDesc $j -name -value]
  3142         -                            dict set data $attrs(-typekind) $attrs(-guid) -values $vardata(-name) $vardata(-value)
  3143         -                        }
  3144         -                    }
  3145         -
  3146         -                    interface {
  3147         -                        # TBD
  3148         -                    }
  3149         -                    coclass {
  3150         -                        dict set data "coclass" $attrs(-guid) -name $name
  3151         -                        for {set j 0} {$j < $attrs(-interfacecount)} {incr j} {
  3152         -                            set ti2 [$ti @GetRefTypeInfoFromIndex $j]
  3153         -                            set iflags [$ti GetImplTypeFlags $j]
  3154         -                            set iguid [twapi::kl_get [$ti2 GetTypeAttr] guid]
  3155         -                            set iname [$ti2 @GetName]
  3156         -                            $ti2 Release
  3157         -                            unset ti2; # So finally clause does not relese again on error
  3158         -
  3159         -                            dict set data "coclass" $attrs(-guid) -interfaces $iguid -name $iname
  3160         -                            dict set data "coclass" $attrs(-guid) -interfaces $iguid -flags $iflags
  3161         -                        }
  3162         -                    }
  3163         -                    default {
  3164         -                        # TBD
  3165         -                    }
  3166         -                }
  3167         -            } finally {
  3168         -                $ti Release
  3169         -                if {[info exists ti2]} {
  3170         -                    $ti2 Release
  3171         -                }
  3172         -            }
  3173         -        }
  3174         -        return $data
  3175         -    }
  3176         -
  3177         -    twapi_exportall
  3178         -}
  3179         -
  3180         -# ITypeComp
  3181         -#----------
  3182         -twapi::class create ::twapi::ITypeCompProxy {
  3183         -    superclass ::twapi::IUnknownProxy
  3184         -
  3185         -    method Bind {name lhash flags} {
  3186         -        my variable _ifc
  3187         -        return [::twapi::ITypeComp_Bind $_ifc $name $lhash $flags]
  3188         -    }
  3189         -
  3190         -    # Returns empty list if bind not found
  3191         -    method @Bind {name flags {lcid 0}} {
  3192         -        ::twapi::trap {
  3193         -            set binding [my Bind $name [::twapi::LHashValOfName $lcid $name] $flags]
  3194         -        } onerror {TWAPI_WIN32 0x80028ca0} {
  3195         -            # Found but type mismatch (flags not correct)
  3196         -            return {}
  3197         -        }
  3198         -
  3199         -        lassign $binding type data tifc
  3200         -        return [list $type $data [::twapi::make_interface_proxy $tifc]]
  3201         -    }
  3202         -
  3203         -    twapi_exportall
  3204         -}
  3205         -
  3206         -# IEnumVARIANT
  3207         -#-------------
  3208         -
  3209         -twapi::class create ::twapi::IEnumVARIANTProxy {
  3210         -    superclass ::twapi::IUnknownProxy
  3211         -
  3212         -    method Next {count {value_only 0}} {
  3213         -        my variable _ifc
  3214         -        return [::twapi::IEnumVARIANT_Next $_ifc $count $value_only]
  3215         -    }
  3216         -    method Clone {} {
  3217         -        my variable _ifc
  3218         -        return [::twapi::IEnumVARIANT_Clone $_ifc]
  3219         -    }
  3220         -    method @Clone {} {
  3221         -        return [::twapi::make_interface_proxy [my Clone]]
  3222         -    }
  3223         -    method Reset {} {
  3224         -        my variable _ifc
  3225         -        return [::twapi::IEnumVARIANT_Reset $_ifc]
  3226         -    }
  3227         -    method Skip {count} {
  3228         -        my variable _ifc
  3229         -        return [::twapi::IEnumVARIANT_Skip $_ifc $count]
  3230         -    }
  3231         -
  3232         -    twapi_exportall
  3233         -}
  3234         -
  3235         -# Automation
  3236         -#-----------
  3237         -twapi::class create ::twapi::Automation {
  3238         -
  3239         -    # Caller gives up ownership of proxy in all cases, even errors.
  3240         -    # $proxy will eventually be Release'ed. If caller wants to keep
  3241         -    # a reference to it, it must do an *additional* AddRef on it to
  3242         -    # keep it from going away when the Automation object releases it.
  3243         -    constructor {proxy {lcid 0}} {
  3244         -        my variable _proxy _lcid  _sinks _connection_pts
  3245         -
  3246         -        set type [$proxy @Type]
  3247         -        if {$type ne "IDispatch" && $type ne "IDispatchEx"} {
  3248         -            $proxy Release;     # Even on error, responsible for releasing
  3249         -            error "Automation objects do not support interfaces of type '$type'"
  3250         -        }
  3251         -        if {$type eq "IDispatchEx"} {
  3252         -            my variable _have_dispex
  3253         -            # If _have_dispex variable
  3254         -            #   - does not exist, have not tried to get IDispatchEx yet
  3255         -            #   - is 0, have tried but failed
  3256         -            #   - is 1, already have IDispatchEx
  3257         -            set _have_dispex 1
  3258         -        }
  3259         -
  3260         -        set _proxy $proxy
  3261         -        set _lcid $lcid
  3262         -        array set _sinks {}
  3263         -        array set _connection_pts {}
  3264         -    }
  3265         -
  3266         -    destructor {
  3267         -        my variable _proxy  _sinks
  3268         -
  3269         -        # Release sinks, connection points
  3270         -        foreach sinkid [array names _sinks] {
  3271         -            my -unbind $sinkid
  3272         -        }
  3273         -
  3274         -        if {[info exists _proxy]} {
  3275         -            $_proxy Release
  3276         -        }
  3277         -        return
  3278         -    }
  3279         -
  3280         -    # Intended to be called only from another method. Not directly.
  3281         -    # Does an uplevel 2 to get to application context.
  3282         -    # On failures, retries with IDispatchEx interface
  3283         -    # TBD - get rid of this uplevel business by having internal
  3284         -    # callers to equivalent of "uplevel 1 my _invoke ...
  3285         -    method _invoke {name invkinds params args} {
  3286         -        my variable  _proxy  _lcid
  3287         -
  3288         -        if {[$_proxy @Null?]} {
  3289         -            error "Attempt to invoke method $name on NULL COM object"
  3290         -        }
  3291         -
  3292         -        array set opts [twapi::parseargs args {
  3293         -            raw.bool
  3294         -            namedargs.arg
  3295         -        } -nulldefault -maxleftover 0]
  3296         -
  3297         -        ::twapi::trap {
  3298         -            set vtval [uplevel 2 [list $_proxy @Invoke $name $invkinds $_lcid $params $opts(namedargs)]]
  3299         -            if {$opts(raw)} {
  3300         -                return $vtval
  3301         -            } else {
  3302         -                return [::twapi::variant_value $vtval 0 0 $_lcid]
  3303         -            }
  3304         -        } onerror {} {
  3305         -            # TBD - should we only drop down below to check for IDispatchEx
  3306         -            # for specific error codes. Right now we do it for all.
  3307         -            set erinfo $::errorInfo
  3308         -            set ercode $::errorCode
  3309         -            set ermsg [::twapi::trapresult]
  3310         -        }
  3311         -
  3312         -        # We plan on trying to get a IDispatchEx interface in case
  3313         -        # the method/property is the "expando" type
  3314         -        my variable  _have_dispex
  3315         -        if {[info exists _have_dispex]} {
  3316         -            # We have already tried for IDispatchEx, either successfully
  3317         -            # or not. Either way, no need to try again
  3318         -            error $ermsg $erinfo $ercode
  3319         -        }
  3320         -
  3321         -        # Try getting a IDispatchEx interface
  3322         -        if {[catch {$_proxy @QueryInterface IDispatchEx 1} proxy_ex] ||
  3323         -            $proxy_ex eq ""} {
  3324         -            set _have_dispex 0
  3325         -            error $ermsg $erinfo $ercode
  3326         -        }
  3327         -
  3328         -        set _have_dispex 1
  3329         -        $_proxy Release
  3330         -        set _proxy $proxy_ex
  3331         -        
  3332         -        # Retry with the IDispatchEx interface
  3333         -        set vtval [uplevel 2 [list $_proxy @Invoke $name $invkinds $_lcid $params $opts(namedargs)]]
  3334         -        if {$opts(raw)} {
  3335         -            return $vtval
  3336         -        } else {
  3337         -            return [::twapi::variant_value $vtval 0 0 $_lcid]
  3338         -        }
  3339         -    }
  3340         -
  3341         -    method -get {name args} {
  3342         -        return [my _invoke $name [list 2] $args]
  3343         -    }
  3344         -
  3345         -    method -set {name args} {
  3346         -        return [my _invoke $name [list 4] $args]
  3347         -    }
  3348         -
  3349         -    method -call {name args} {
  3350         -        return [my _invoke $name [list 1] $args]
  3351         -    }
  3352         -
  3353         -    method -callnamedargs {name args} {
  3354         -        return [my _invoke $name [list 1] {} -namedargs $args]
  3355         -    }
  3356         -
  3357         -    # Need a wrapper around _invoke in order for latter's uplevel 2
  3358         -    # to work correctly
  3359         -    # TBD - document, test
  3360         -    method -invoke {name invkinds params args} {
  3361         -        return [my _invoke $name $invkinds $params {*}$args]
  3362         -    }
  3363         -
  3364         -    method -destroy {} {
  3365         -        my destroy
  3366         -    }
  3367         -
  3368         -    method -isnull {} {
  3369         -        my variable _proxy
  3370         -        return [$_proxy @Null?]
  3371         -    }
  3372         -
  3373         -    method -default {} {
  3374         -        my variable _proxy _lcid
  3375         -        return [::twapi::variant_value [$_proxy Invoke ""] 0 0 $_lcid]
  3376         -    }
  3377         -
  3378         -    # Caller must call release on the proxy
  3379         -    method -proxy {} {
  3380         -        my variable _proxy
  3381         -        $_proxy AddRef
  3382         -        return $_proxy
  3383         -    }
  3384         -
  3385         -    # Only for debugging
  3386         -    method -proxyrefcounts {} {
  3387         -        my variable _proxy
  3388         -        return [$_proxy DebugRefCounts]
  3389         -    }
  3390         -
  3391         -    # Returns the raw interface. Caller must call IUnknownRelease on it
  3392         -    # iff addref is passed as true (default)
  3393         -    method -interface {{addref 1}} {
  3394         -        my variable _proxy
  3395         -        return [$_proxy @Interface $addref]
  3396         -    }
  3397         -
  3398         -    # Validates internal structures
  3399         -    method -validate {} {
  3400         -        twapi::ValidateIUnknown [my -interface 0]
  3401         -    }
  3402         -
  3403         -    # Set/return the GUID for the interface
  3404         -    method -interfaceguid {{guid ""}} {
  3405         -        my variable _proxy
  3406         -        return [$_proxy @SetGuid $guid]
  3407         -    }
  3408         -
  3409         -    # Return the disp id for a method/property
  3410         -    method -dispid {name} {
  3411         -        my variable _proxy
  3412         -        return [$_proxy @GetIDOfOneName $name]
  3413         -    }
  3414         -
  3415         -    # Prints methods in an interface
  3416         -    method -print {} {
  3417         -        my variable _proxy
  3418         -        ::twapi::dispatch_print $_proxy
  3419         -    }
  3420         -
  3421         -    method -with {subobjlist args} {
  3422         -        # $obj -with SUBOBJECTPATHLIST arguments
  3423         -        # where SUBOBJECTPATHLIST is list each element of which is
  3424         -        # either a property or a method of the previous element in
  3425         -        # the list. The element may itself be a list in which case
  3426         -        # the first element is the property/method and remaining
  3427         -        # are passed to it
  3428         -        #
  3429         -        # Note that 'arguments' may themselves be comobj subcommands!
  3430         -        set next [self]
  3431         -        set releaselist [list ]
  3432         -        ::twapi::trap {
  3433         -            while {[llength $subobjlist]} {
  3434         -                set nextargs [lindex $subobjlist 0]
  3435         -                set subobjlist [lrange $subobjlist 1 end]
  3436         -                set next [uplevel 1 [list $next] $nextargs]
  3437         -                lappend releaselist $next
  3438         -            }
  3439         -            # We use uplevel here because again we want to run in caller
  3440         -            # context 
  3441         -            return [uplevel 1 [list $next] $args]
  3442         -        } finally {
  3443         -            foreach next $releaselist {
  3444         -                $next -destroy
  3445         -            }
  3446         -        }
  3447         -    }
  3448         -
  3449         -    method -iterate {args} {
  3450         -        my variable _lcid
  3451         -
  3452         -        array set opts [::twapi::parseargs args {
  3453         -            cleanup
  3454         -        }]
  3455         -
  3456         -        if {[llength $args] < 2} {
  3457         -            error "Syntax: COMOBJ -iterate ?options? VARNAME SCRIPT"
  3458         -        }
  3459         -        upvar 1 [lindex $args 0] var
  3460         -        set script [lindex $args 1]
  3461         -
  3462         -        # TBD - need more comprehensive test cases when return/break/continue
  3463         -        # are used in the script
  3464         -
  3465         -        # First get IEnumVariant iterator using the _NewEnum method
  3466         -        # TBD - As per MS OLE Automation spec, it appears _NewEnum
  3467         -        # MUST have dispid -4. Can we use this information when
  3468         -        # this object does not have an associated interface guid or
  3469         -        # when no prototype is available ?
  3470         -        set enumerator [my -get _NewEnum]
  3471         -        # This gives us an IUnknown.
  3472         -        ::twapi::trap {
  3473         -            # Convert the IUnknown to IEnumVARIANT
  3474         -            set iter [$enumerator @QueryInterface IEnumVARIANT]
  3475         -            if {! [$iter @Null?]} {
  3476         -                set more 1
  3477         -                while {$more} {
  3478         -                    # Get the next item from iterator
  3479         -                    set next [$iter Next 1]
  3480         -                    lassign $next more values
  3481         -                    if {[llength $values]} {
  3482         -                        set var [::twapi::variant_value [lindex $values 0] 0 0 $_lcid]
  3483         -                        set ret [catch {uplevel 1 $script} msg options]
  3484         -                        switch -exact -- $ret {
  3485         -                            0 -
  3486         -                            4 {
  3487         -                                # Body executed successfully, or invoked continue
  3488         -                                if {$opts(cleanup)} {
  3489         -                                    $var destroy
  3490         -                                }
  3491         -                            }
  3492         -                            3 {
  3493         -                                if {$opts(cleanup)} {
  3494         -                                    $var destroy
  3495         -                                }
  3496         -                                set more 0; # TCL_BREAK
  3497         -                            }
  3498         -                            1 -
  3499         -                            2 -
  3500         -                            default {
  3501         -                                if {$opts(cleanup)} {
  3502         -                                    $var destroy
  3503         -                                }
  3504         -                                dict incr options -level
  3505         -                                return -options $options $msg
  3506         -                            }
  3507         -
  3508         -                        }
  3509         -                    }
  3510         -                }
  3511         -            }
  3512         -        } finally {
  3513         -            $enumerator Release
  3514         -            if {[info exists iter] && ![$iter @Null?]} {
  3515         -                $iter Release
  3516         -            }
  3517         -        }
  3518         -        return
  3519         -    }
  3520         -
  3521         -    method -bind {script} {
  3522         -        my variable   _proxy   _sinks    _connection_pts
  3523         -
  3524         -        # Get the coclass typeinfo and  locate the source interface
  3525         -        # within it and retrieve disp id mappings
  3526         -        ::twapi::trap {
  3527         -            set coti [$_proxy @GetCoClassTypeInfo]
  3528         -
  3529         -            # $coti is the coclass information. Get dispids for the default
  3530         -            # source interface for events and its guid
  3531         -            set srcti [$coti @GetDefaultSourceTypeInfo]
  3532         -            array set srcinfo [$srcti @GetTypeAttr -memidmap -guid]
  3533         -
  3534         -            # TBD - implement IConnectionPointContainerProxy
  3535         -            # Now we need to get the actual connection point itself
  3536         -            set container [$_proxy QueryInterface IConnectionPointContainer]
  3537         -            set connpt_ifc [::twapi::IConnectionPointContainer_FindConnectionPoint $container $srcinfo(-guid)]
  3538         -
  3539         -            # Finally, create our sink object
  3540         -            # TBD - need to make sure Automation object is not deleted or
  3541         -            # should the callback itself check?
  3542         -            # TBD - what guid should we be passing? CLSID or IID ?
  3543         -            set sink_ifc [::twapi::Twapi_ComServer $srcinfo(-guid) $srcinfo(-memidmap) [list ::twapi::_eventsink_callback [self] $script]]
  3544         -
  3545         -            # OK, we finally have everything we need. Tell the event source
  3546         -            set sinkid [::twapi::IConnectionPoint_Advise $connpt_ifc $sink_ifc]
  3547         -            
  3548         -            set _sinks($sinkid) $sink_ifc
  3549         -            set _connection_pts($sinkid) $connpt_ifc
  3550         -            return $sinkid
  3551         -        } onerror {} {
  3552         -            # These are released only on error as otherwise they have
  3553         -            # to be kept until unbind time
  3554         -            foreach ifc {connpt_ifc sink_ifc} {
  3555         -                if {[info exists $ifc] && [set $ifc] ne ""} {
  3556         -                    ::twapi::IUnknown_Release [set $ifc]
  3557         -                }
  3558         -            }
  3559         -            twapi::rethrow
  3560         -        } finally {
  3561         -            # In all cases, release any interfaces we created
  3562         -            # Note connpt_ifc and sink_ifc are released at unbind time except
  3563         -            # on error
  3564         -            foreach obj {coti srcti} {
  3565         -                if {[info exists $obj]} {
  3566         -                    [set $obj] Release
  3567         -                }
  3568         -            }
  3569         -            if {[info exists container]} {
  3570         -                ::twapi::IUnknown_Release $container
  3571         -            }
  3572         -        }
  3573         -    }
  3574         -
  3575         -    method -unbind {sinkid} {
  3576         -        my variable   _proxy   _sinks    _connection_pts
  3577         -
  3578         -        if {[info exists _connection_pts($sinkid)]} {
  3579         -            ::twapi::IConnectionPoint_Unadvise $_connection_pts($sinkid) $sinkid
  3580         -            unset _connection_pts($sinkid)
  3581         -        }
  3582         -
  3583         -        if {[info exists _sinks($sinkid)]} {
  3584         -            ::twapi::IUnknown_Release $_sinks($sinkid)
  3585         -            unset _sinks($sinkid)
  3586         -        }
  3587         -        return
  3588         -    }
  3589         -
  3590         -    method -securityblanket {args} {
  3591         -        my variable _proxy
  3592         -        if {[llength $args]} {
  3593         -            $_proxy @SetSecurityBlanket [lindex $args 0]
  3594         -            return
  3595         -        } else {
  3596         -            return [$_proxy @GetSecurityBlanket]
  3597         -        }
  3598         -    }
  3599         -
  3600         -    method -lcid {{lcid ""}} {
  3601         -        my variable _lcid
  3602         -        if {$lcid ne ""} {
  3603         -            if {![string is integer -strict $lcid]} {
  3604         -                error "Invalid LCID $lcid"
  3605         -            }
  3606         -            set _lcid $lcid
  3607         -        }
  3608         -        return $_lcid
  3609         -    }
  3610         -
  3611         -    method unknown {name args} {
  3612         -        # Try to figure out whether it is a property or method
  3613         -
  3614         -        # We have to figure out if it is a property get, property put
  3615         -        # or a method. We make a guess based on number of parameters.
  3616         -        # We specify an order to try based on this. The invoke will try
  3617         -        # all invocations in that order.
  3618         -        # TBD - what about propputref ?
  3619         -        set nargs [llength $args]
  3620         -        if {$nargs == 0} {
  3621         -            # No arguments, cannot be propput. Try propget and method
  3622         -            set invkinds [list 2 1]
  3623         -        } elseif {$nargs == 1} {
  3624         -            # One argument, likely propput, method, propget
  3625         -            set invkinds [list 4 1 2]
  3626         -        } else {
  3627         -            # Multiple arguments, likely method, propput, propget
  3628         -            set invkinds [list 1 4 2]
  3629         -        }
  3630         -
  3631         -        # TBD - should this do an uplevel ?
  3632         -        return [my _invoke $name $invkinds $args]
  3633         -    }
  3634         -
  3635         -    twapi_exportall
  3636         -}
  3637         -
  3638         -#
  3639         -# Singleton NULL comobj object. We want to override default destroy methods
  3640         -# to prevent object from being destroyed. This is a backward compatibility
  3641         -# hack and not fool proof since the command could just be renamed away.
  3642         -twapi::class create twapi::NullAutomation {
  3643         -    superclass twapi::Automation
  3644         -    constructor {} {
  3645         -        next [twapi::make_interface_proxy {0 IDispatch}]
  3646         -    }
  3647         -    method -destroy {}  {
  3648         -        # Silently ignore
  3649         -    }
  3650         -    method destroy {}  {
  3651         -        # Silently ignore
  3652         -    }
  3653         -    twapi_exportall
  3654         -}
  3655         -
  3656         -twapi::NullAutomation create twapi::comobj_null
  3657         -# twapi::Automation create twapi::comobj_null [twapi::make_interface_proxy {0 IDispatch}]
  3658         -
  3659         -proc twapi::_comobj_cleanup {} {
  3660         -    foreach obj [comobj_instances] {
  3661         -        $obj destroy
  3662         -    }
  3663         -}
  3664         -
  3665         -# In order for servers to release objects properly, the IUnknown interface
  3666         -# must have the same security settings as were used in the object creation
  3667         -# call. This is a helper for that.
  3668         -proc twapi::_com_set_iunknown_proxy {ifc blanket} {
  3669         -    set iunk [Twapi_IUnknown_QueryInterface $ifc [_iid_iunknown] IUnknown]
  3670         -    trap {
  3671         -        CoSetProxyBlanket $iunk {*}$blanket
  3672         -    } finally {
  3673         -        IUnknown_Release $iunk
  3674         -    }
  3675         -}
  3676         -
  3677         -
  3678         -twapi::proc* twapi::_init_authnames {} {
  3679         -    variable _com_authsvc_to_name 
  3680         -    variable _com_name_to_authsvc
  3681         -    variable _com_impersonation_to_name
  3682         -    variable _com_name_to_impersonation
  3683         -    variable _com_authlevel_to_name
  3684         -    variable _com_name_to_authlevel
  3685         -
  3686         -    set _com_authsvc_to_name {0 none 9 negotiate 10 ntlm 14 schannel 16 kerberos 0xffffffff default}
  3687         -    set _com_name_to_authsvc [swapl $_com_authsvc_to_name]
  3688         -    set _com_name_to_impersonation {default 0 anonymous 1 identify 2 impersonate 3 delegate 4}
  3689         -    set _com_impersonation_to_name [swapl $_com_name_to_impersonation]
  3690         -    set _com_name_to_authlevel {default 0 none 1 connect 2 call 3 packet 4 packetintegrity 5 privacy 6}
  3691         -    set _com_authlevel_to_name [swapl $_com_name_to_authlevel]
  3692         -} {
  3693         -}
  3694         -
  3695         -twapi::proc* twapi::_com_authsvc_to_name {authsvc} {
  3696         -    _init_authnames
  3697         -} {
  3698         -    variable _com_authsvc_to_name
  3699         -    return [dict* $_com_authsvc_to_name $authsvc]
  3700         -}
  3701         -
  3702         -twapi::proc* twapi::_com_name_to_authsvc {name} {
  3703         -    _init_authnames
  3704         -} {
  3705         -    variable _com_name_to_authsvc
  3706         -    if {[string is integer -strict $name]} {
  3707         -        return $name
  3708         -    }
  3709         -    return [dict! $_com_name_to_authsvc $name]
  3710         -}
  3711         -
  3712         -twapi::proc* twapi::_com_authlevel_to_name {authlevel} {
  3713         -    _init_authnames
  3714         -} {
  3715         -    variable _com_authlevel_to_name
  3716         -    return [dict* $_com_authlevel_to_name $authlevel]
  3717         -}
  3718         -
  3719         -twapi::proc* twapi::_com_name_to_authlevel {name} {
  3720         -    _init_authnames
  3721         -} {
  3722         -    variable _com_name_to_authlevel
  3723         -    if {[string is integer -strict $name]} {
  3724         -        return $name
  3725         -    }
  3726         -    return [dict! $_com_name_to_authlevel $name]
  3727         -}
  3728         -
  3729         -
  3730         -twapi::proc* twapi::_com_impersonation_to_name {imp} {
  3731         -    _init_authnames
  3732         -} {
  3733         -    variable _com_impersonation_to_name
  3734         -    return [dict* $_com_impersonation_to_name $imp]
  3735         -}
  3736         -
  3737         -twapi::proc* twapi::_com_name_to_impersonation {name} {
  3738         -    _init_authnames
  3739         -} {
  3740         -    variable _com_name_to_impersonation
  3741         -    if {[string is integer -strict $name]} {
  3742         -        return $name
  3743         -    }
  3744         -    return [dict! $_com_name_to_impersonation $name]
  3745         -}
  3746         -
  3747         -#################################################################
  3748         -# COM server implementation
  3749         -# WARNING: do not use any fancy TclOO features because it has to
  3750         -# run under 8.5/metoo as well
  3751         -# TBD - test scripts?
  3752         -
  3753         -twapi::class create twapi::ComFactory {
  3754         -    constructor {clsid member_map create_command_prefix} {
  3755         -        my variable _clsid _create_command_prefix _member_map _ifc
  3756         -
  3757         -        set _clsid $clsid
  3758         -        set _member_map $member_map
  3759         -        set _create_command_prefix $create_command_prefix
  3760         -
  3761         -        set _ifc [twapi::Twapi_ClassFactory $_clsid [list [self] _create_instance]]
  3762         -    }
  3763         -
  3764         -    destructor {
  3765         -        # TBD - what happens if factory is destroyed while objects still
  3766         -        # exist ?
  3767         -        # App MUST explicitly destroy objects before exiting
  3768         -        my variable _class_registration_id
  3769         -        if {[info exists _class_registration_id]} {
  3770         -            twapi::CoRevokeClassObject $_class_registration_id
  3771         -        }
  3772         -    }
  3773         -
  3774         -    # Called from Twapi_ClassFactory_CreateInstance to create a new object
  3775         -    # Should not be called from elsewhere
  3776         -    method _create_instance {iid} {
  3777         -        my variable _create_command_prefix _member_map
  3778         -        # Note [list {*}$foo] != $foo - consider when foo contains a ";"
  3779         -        set obj_prefix [uplevel #0 [list {*}$_create_command_prefix]]
  3780         -        twapi::trap {
  3781         -            # Since we are not holding on to this interface ourselves,
  3782         -            # we can pass it on without AddRef'ing it
  3783         -            return [twapi::Twapi_ComServer $iid $_member_map $obj_prefix]
  3784         -        } onerror {} {
  3785         -            $obj_prefix destroy
  3786         -            twapi::rethrow
  3787         -        }
  3788         -    }
  3789         -
  3790         -    method register {args} {
  3791         -        my variable _clsid _create_command_prefix _member_map _ifc _class_registration_id
  3792         -        twapi::parseargs args {
  3793         -            {model.arg any}
  3794         -        } -setvars -maxleftover 0
  3795         -        set model_flags 0
  3796         -        foreach m $model {
  3797         -            switch -exact -- $m {
  3798         -                any           {twapi::setbits model_flags 20}
  3799         -                localserver   {twapi::setbits model_flags 4}
  3800         -                remoteserver  {twapi::setbits model_flags 16}
  3801         -                default {twapi::badargs! "Invalid COM class model '$m'"}
  3802         -            }
  3803         -        }
  3804         -        
  3805         -        # 0x6 -> REGCLS_MULTI_SEPARATE | REGCLS_SUSPENDED
  3806         -        set _class_registration_id [twapi::CoRegisterClassObject $_clsid $_ifc $model_flags 0x6]
  3807         -        return
  3808         -    }
  3809         -    
  3810         -    export _create_instance
  3811         -}
  3812         -
  3813         -proc twapi::comserver_factory {clsid member_map command_prefix {name {}}} {
  3814         -    if {$name ne ""} {
  3815         -        uplevel 1 [list [namespace current]::ComFactory create $name $clsid $member_map $command_prefix]
  3816         -    } else {
  3817         -        uplevel 1 [list [namespace current]::ComFactory new $clsid $member_map $command_prefix]
  3818         -    }
  3819         -}
  3820         -
  3821         -proc twapi::start_factories {{cmd {}}} {
  3822         -    # TBD - what if no class objects ?
  3823         -    CoResumeClassObjects
  3824         -
  3825         -    if {[llength $cmd]} {
  3826         -        # TBD - normalize $cmd so to run in right namespace etc.
  3827         -        trace add variable [namspace current]::com_shutdown_signal write $cmd
  3828         -        return
  3829         -    }
  3830         -
  3831         -    # This is set from the C code when we are not serving up any
  3832         -    # COM objects (either event callbacks or com servers)
  3833         -    vwait [namespace current]::com_shutdown_signal
  3834         -}
  3835         -
  3836         -proc twapi::suspend_factories {} {
  3837         -    CoSuspendClassObjects
  3838         -}
  3839         -
  3840         -proc twapi::resume_factories {} {
  3841         -    CoResumeClassObjects
  3842         -}
  3843         -
  3844         -proc twapi::install_coclass_script {progid clsid version script_path args} {
  3845         -    # Need to extract params so we can prefix script name
  3846         -    set saved_args $args
  3847         -    array set opts [parseargs args {
  3848         -        params.arg
  3849         -    } -ignoreunknown]
  3850         -
  3851         -    set script_path [file normalize $script_path]
  3852         -
  3853         -    # Try to locate the wish executable to run the component
  3854         -    if {[info commands wm] eq ""} {
  3855         -        set dir [file dirname [info nameofexecutable]]
  3856         -        set wishes [glob -nocomplain -directory $dir wish*.exe]
  3857         -        if {[llength $wishes] == 0} {
  3858         -            error "Could not locate wish program."
  3859         -        }
  3860         -        set wish [lindex $wishes 0]
  3861         -    } else {
  3862         -        # We are running wish already
  3863         -        set wish [info nameofexecutable]
  3864         -    }
  3865         -
  3866         -    set exe_path [file nativename [file attributes $wish -shortname]]
  3867         -
  3868         -    set params "\"$script_path\""
  3869         -    if {[info exists opts(params)]} {
  3870         -        append params " $params"
  3871         -    }
  3872         -    return [install_coclass $progid $clsid $version $exe_path {*}$args -outproc -params $params]
  3873         -}
  3874         -
  3875         -proc twapi::install_coclass {progid clsid version path args} {
  3876         -    array set opts [twapi::parseargs args {
  3877         -        {scope.arg user {user system}}
  3878         -        appid.arg
  3879         -        appname.arg
  3880         -        inproc
  3881         -        outproc
  3882         -        service
  3883         -        params.arg
  3884         -        name.arg
  3885         -    } -maxleftover 0]
  3886         -
  3887         -    switch [tcl::mathop::+ $opts(inproc) $opts(outproc) $opts(service)] {
  3888         -        0 {
  3889         -            # Need to figure out the type
  3890         -            switch [file extension $path] {
  3891         -                .exe { set opts(outproc) 1 }
  3892         -                .ocx -
  3893         -                .dll { set opts(inproc) 1 }
  3894         -                default { set opts(service) 1 }
  3895         -            }
  3896         -        }
  3897         -        1 {}
  3898         -        default {
  3899         -            badargs! "Only one of -inproc, -outproc or -service may be specified"
  3900         -        }
  3901         -    }
  3902         -
  3903         -    if {(! [string is integer -strict $version]) || $version <= 0} {
  3904         -        twapi::badargs! "Invalid version '$version'. Must be a positive integer"
  3905         -    }
  3906         -    if {![regexp {^[[:alpha:]][[:alnum:]]*\.[[:alpha:]][[:alnum:]]*$} $progid]} {
  3907         -        badargs! "Invalid PROGID syntax '$progid'"
  3908         -    }
  3909         -    set clsid [canonicalize_guid $clsid]
  3910         -    if {![info exists opts(appid)]} {
  3911         -        # This is what dcomcnfg and oleview do - default to the CLSID
  3912         -        set opts(appid) $clsid
  3913         -    } else {
  3914         -        set opts(appid) [canonicalize_guid $opts(appid)]
  3915         -    }
  3916         -
  3917         -    if {$opts(scope) eq "user"} {
  3918         -        if {$opts(service)} {
  3919         -            twapi::badargs! "Option -service cannot be specified if -scope is \"user\""
  3920         -        }
  3921         -        set regtop HKEY_CURRENT_USER
  3922         -    } else {
  3923         -        set regtop HKEY_LOCAL_MACHINE
  3924         -    }
  3925         -
  3926         -    set progid_path "$regtop\\Software\\Classes\\$progid"
  3927         -    set clsid_path "$regtop\\Software\\Classes\\CLSID\\$clsid"
  3928         -    set appid_path "$regtop\\Software\\Classes\\AppID\\$opts(appid)"
  3929         -
  3930         -    if {$opts(service)} {
  3931         -        # TBD
  3932         -        badargs! "Option -service is not implemented"
  3933         -    } elseif {$opts(outproc)} {
  3934         -        if {[info exists opts(params)]} {
  3935         -            registry set "$clsid_path\\LocalServer32" "" "\"[file nativename [file normalize $path]]\" $opts(params)"
  3936         -        } else {
  3937         -            registry set "$clsid_path\\LocalServer32" "" "\"[file nativename [file normalize $path]]\""
  3938         -        }
  3939         -        # TBD - We do not quote path for ServerExecutable, should we ?
  3940         -        registry set "$clsid_path\\LocalServer32" "ServerExecutable" [file nativename [file normalize $path]]
  3941         -    } else {
  3942         -        # TBD - We do not quote path here either, should we ?
  3943         -        registry set "$clsid_path\\InprocServer32" "" [file nativename [file normalize $path]]
  3944         -    }
  3945         -    
  3946         -    registry set "$clsid_path\\ProgID" "" "$progid.$version"
  3947         -    registry set "$clsid_path\\VersionIndependentProgID" "" $progid
  3948         -
  3949         -    # Set the registry under the progid and progid.version
  3950         -    registry set "$progid_path\\CLSID" "" $clsid
  3951         -    registry set "$progid_path\\CurVer" "" "$progid.$version"
  3952         -    if {[info exists opts(name)]} {
  3953         -        registry set $progid_path "" $opts(name)
  3954         -    }
  3955         -
  3956         -    append progid_path ".$version"
  3957         -    registry set "$progid_path\\CLSID" "" $clsid
  3958         -    if {[info exists opts(name)]} {
  3959         -        registry set $progid_path "" $opts(name)
  3960         -    }
  3961         -    
  3962         -    registry set $clsid_path "AppID" $opts(appid)
  3963         -    registry set $appid_path;   # Always create the key even if nothing below
  3964         -    if {[info exists opts(appname)]} {
  3965         -        registry set $appid_path "" $opts(appname)
  3966         -    }
  3967         -    
  3968         -    if {$opts(service)} {
  3969         -        registry set $appid_path "LocalService" $path
  3970         -        if {[info exists opts(params)]} {
  3971         -            registry set $appid_path "ServiceParameters" $opts(params)
  3972         -        }
  3973         -    }
  3974         -
  3975         -    return
  3976         -}
  3977         -
  3978         -proc twapi::uninstall_coclass {progid args} {
  3979         -    # Note "CLSID" itself is a valid ProgID (it has a CLSID key below it)
  3980         -    # Also we want to protect against horrible errors that blow away
  3981         -    # entire branches if progid is empty, wrong value, etc.
  3982         -    # So only work with keys of the form X.X
  3983         -    if {![regexp {^[[:alpha:]][[:alnum:]]*\.[[:alpha:]][[:alnum:]]*$} $progid]} {
  3984         -        badargs! "Invalid PROGID syntax '$progid'"
  3985         -    }
  3986         -
  3987         -    # Do NOT want to delete the CLSID key by mistake. Note below checks
  3988         -    # will not protect against this since they will return a valid value 
  3989         -    # if progid is "CLSID" since that has a CLSID key below it as well.
  3990         -    if {[string equal -nocase $progid CLSID]} {
  3991         -        badargs! "Attempt to delete protected key 'CLSID'"
  3992         -    }
  3993         -
  3994         -    array set opts [twapi::parseargs args {
  3995         -        {scope.arg user {user system}}
  3996         -        keepappid
  3997         -    } -maxleftover 0]
  3998         -
  3999         -    switch -exact -- $opts(scope) {
  4000         -        user { set regtop HKEY_CURRENT_USER }
  4001         -        system { set regtop HKEY_LOCAL_MACHINE }
  4002         -        default {
  4003         -            badargs! "Invalid class registration scope '$opts(scope)'. Must be 'user' or 'system'"
  4004         -        }
  4005         -    }
  4006         -
  4007         -    if {0} {
  4008         -        # Do NOT use this. If running under elevated, it will ignore
  4009         -        # HKEY_CURRENT_USER.
  4010         -        set clsid [progid_to_clsid $progid]; # Also protects against bogus progids
  4011         -    } else {
  4012         -        set clsid [registry get "$regtop\\Software\\Classes\\$progid\\CLSID" ""]
  4013         -    }
  4014         -
  4015         -    # Should not be empty at this point but do not want to delete the 
  4016         -    # whole Classes tree in case progid or clsid are empty strings
  4017         -    # because of some bug! That would be an epic disaster so try and
  4018         -    # protect.
  4019         -    if {$clsid eq ""} {
  4020         -        badargs! "CLSID corresponding to PROGID '$progid' is empty"
  4021         -    }
  4022         -    
  4023         -    # See if we need to delete the linked current version
  4024         -    if {! [catch {
  4025         -        registry get "$regtop\\Software\\Classes\\$progid\\CurVer" ""
  4026         -    } curver]} {
  4027         -        if {[string match -nocase ${progid}.* $curver]} {
  4028         -            registry delete "$regtop\\Software\\Classes\\$curver"
  4029         -        }
  4030         -    }
  4031         -
  4032         -    # See if we need to delete the APPID
  4033         -    if {! $opts(keepappid)} {
  4034         -        if {! [catch {
  4035         -            registry get "$regtop\\Software\\Classes\\CLSID\\$clsid" "AppID"
  4036         -        } appid]} {
  4037         -            # Validate it is a real GUID
  4038         -            if {![catch {canonicalize_guid $appid}]} {
  4039         -                registry delete "$regtop\\Software\\Classes\\AppID\\$appid"
  4040         -            }
  4041         -        }
  4042         -    }
  4043         -
  4044         -    # Finally delete the keys and hope we have not trashed the system
  4045         -    registry delete "$regtop\\Software\\Classes\\CLSID\\$clsid"
  4046         -    registry delete "$regtop\\Software\\Classes\\$progid"
  4047         -
  4048         -    return
  4049         -}
  4050         -
  4051         -

Deleted winlibs/twapi/console.tcl.

     1         -#
     2         -# Copyright (c) 2004-2014, Ashok P. Nadkarni
     3         -# All rights reserved.
     4         -#
     5         -# See the file LICENSE for license
     6         -
     7         -namespace eval twapi {
     8         -}
     9         -
    10         -# Allocate a new console
    11         -proc twapi::allocate_console {} {
    12         -    AllocConsole
    13         -}
    14         -
    15         -# Free a console
    16         -proc twapi::free_console {} {
    17         -    FreeConsole
    18         -}
    19         -
    20         -# Get a console handle
    21         -proc twapi::get_console_handle {type} {
    22         -    switch -exact -- $type {
    23         -        0 -
    24         -        stdin { set fn "CONIN\$" }
    25         -        1 -
    26         -        stdout -
    27         -        2 -
    28         -        stderr { set fn "CONOUT\$" }
    29         -        default {
    30         -            error "Unknown console handle type '$type'"
    31         -        }
    32         -    }
    33         -
    34         -    # 0xC0000000 -> GENERIC_READ | GENERIC_WRITE
    35         -    # 3 -> FILE_SHARE_READ | FILE_SHARE_WRITE
    36         -    # 3 -> OPEN_EXISTING
    37         -    return [CreateFile $fn \
    38         -                0xC0000000 \
    39         -                3 \
    40         -                {{} 1} \
    41         -                3 \
    42         -                0 \
    43         -                NULL]
    44         -}
    45         -
    46         -# Get a console handle
    47         -proc twapi::get_standard_handle {type} {
    48         -    switch -exact -- $type {
    49         -        0 -
    50         -        -11 -
    51         -        stdin { set type -11 }
    52         -        1 -
    53         -        -12 -
    54         -        stdout { set type -12 }
    55         -        2 -
    56         -        -13 -
    57         -        stderr { set type -13 }
    58         -        default {
    59         -            error "Unknown console handle type '$type'"
    60         -        }
    61         -    }
    62         -    return [GetStdHandle $type]
    63         -}
    64         -
    65         -# Set a console handle
    66         -proc twapi::set_standard_handle {type handle} {
    67         -    switch -exact -- $type {
    68         -        0 -
    69         -        -11 -
    70         -        stdin { set type -11 }
    71         -        1 -
    72         -        -12 -
    73         -        stdout { set type -12 }
    74         -        2 -
    75         -        -13 -
    76         -        stderr { set type -13 }
    77         -        default {
    78         -            error "Unknown console handle type '$type'"
    79         -        }
    80         -    }
    81         -    return [SetStdHandle $type $handle]
    82         -}
    83         -
    84         -proc twapi::_console_output_attr_to_flags {attrs} {
    85         -    set flags 0
    86         -    foreach {attr bool} $attrs {
    87         -        if {$bool} {
    88         -            set flags [expr {$flags | [_console_output_attr $attr]}]
    89         -        }
    90         -    }
    91         -    return $flags
    92         -}
    93         -
    94         -proc twapi::_flags_to_console_output_attr {flags} {
    95         -    # Check for multiple bit attributes first, in order
    96         -    set attrs {}
    97         -    foreach attr {
    98         -        -fgwhite -bgwhite -fggray -bggray
    99         -        -fgturquoise -bgturquoise -fgpurple -bgpurple -fgyellow -bgyellow
   100         -        -fgred -bgred -fggreen -bggreen -fgblue -bgblue
   101         -        -fgbright -bgbright
   102         -    } {
   103         -        if {($flags & [_console_output_attr $attr]) == [_console_output_attr $attr]} {
   104         -            lappend attrs $attr 1
   105         -            set flags [expr {$flags & ~ [_console_output_attr $attr]}]
   106         -            if {$flags == 0} {
   107         -                break
   108         -            }
   109         -        }
   110         -    }
   111         -        
   112         -    return $attrs
   113         -}
   114         -
   115         -
   116         -# Get the current mode settings for the console
   117         -proc twapi::_get_console_input_mode {conh} {
   118         -    set mode [GetConsoleMode $conh]
   119         -    return [_bitmask_to_switches $mode [_console_input_mode_syms]]
   120         -}
   121         -interp alias {} twapi::get_console_input_mode {} twapi::_do_console_proc twapi::_get_console_input_mode stdin
   122         -
   123         -# Get the current mode settings for the console
   124         -proc twapi::_get_console_output_mode {conh} {
   125         -    set mode [GetConsoleMode $conh]
   126         -    return [_bitmask_to_switches $mode [_console_output_mode_syms]]
   127         -}
   128         -interp alias {} twapi::get_console_output_mode {} twapi::_do_console_proc twapi::_get_console_output_mode stdout
   129         -
   130         -# Set console input mode
   131         -proc twapi::_set_console_input_mode {conh args} {
   132         -    set mode [_switches_to_bitmask $args [_console_input_mode_syms]]
   133         -    # If insertmode or quickedit mode are set, make sure to set extended bit
   134         -    if {$mode & 0x60} {
   135         -        setbits mode 0x80;              # ENABLE_EXTENDED_FLAGS
   136         -    }
   137         -
   138         -    SetConsoleMode $conh $mode
   139         -}
   140         -interp alias {} twapi::set_console_input_mode {} twapi::_do_console_proc twapi::_set_console_input_mode stdin
   141         -
   142         -# Modify console input mode
   143         -proc twapi::_modify_console_input_mode {conh args} {
   144         -    set prev [GetConsoleMode $conh]
   145         -    set mode [_switches_to_bitmask $args [_console_input_mode_syms] $prev]
   146         -    # If insertmode or quickedit mode are set, make sure to set extended bit
   147         -    if {$mode & 0x60} {
   148         -        setbits mode 0x80;              # ENABLE_EXTENDED_FLAGS
   149         -    }
   150         -
   151         -    SetConsoleMode $conh $mode
   152         -    # Returns the old modes
   153         -    return [_bitmask_to_switches $prev [_console_input_mode_syms]]
   154         -}
   155         -interp alias {} twapi::modify_console_input_mode {} twapi::_do_console_proc twapi::_modify_console_input_mode stdin
   156         -
   157         -#
   158         -# Set console output mode
   159         -proc twapi::_set_console_output_mode {conh args} {
   160         -    set mode [_switches_to_bitmask $args [_console_output_mode_syms]]
   161         -
   162         -    SetConsoleMode $conh $mode
   163         -
   164         -}
   165         -interp alias {} twapi::set_console_output_mode {} twapi::_do_console_proc twapi::_set_console_output_mode stdout
   166         -
   167         -# Set console output mode
   168         -proc twapi::_modify_console_output_mode {conh args} {
   169         -    set prev [GetConsoleMode $conh]
   170         -    set mode [_switches_to_bitmask $args [_console_output_mode_syms] $prev]
   171         -
   172         -    SetConsoleMode $conh $mode
   173         -    # Returns the old modes
   174         -    return [_bitmask_to_switches $prev [_console_output_mode_syms]]
   175         -}
   176         -interp alias {} twapi::modify_console_output_mode {} twapi::_do_console_proc twapi::_modify_console_output_mode stdout
   177         -
   178         -
   179         -# Create and return a handle to a screen buffer
   180         -proc twapi::create_console_screen_buffer {args} {
   181         -    array set opts [parseargs args {
   182         -        {inherit.bool 0}
   183         -        {mode.arg readwrite {read write readwrite}}
   184         -        {secd.arg ""}
   185         -        {share.arg readwrite {none read write readwrite}}
   186         -    } -maxleftover 0]
   187         -
   188         -    switch -exact -- $opts(mode) {
   189         -        read       { set mode [_access_rights_to_mask generic_read] }
   190         -        write      { set mode [_access_rights_to_mask generic_write] }
   191         -        readwrite  {
   192         -            set mode [_access_rights_to_mask {generic_read generic_write}]
   193         -        }
   194         -    }
   195         -    switch -exact -- $opts(share) {
   196         -        none {
   197         -            set share 0
   198         -        }
   199         -        read       {
   200         -            set share 1 ;# FILE_SHARE_READ
   201         -        }
   202         -        write      {
   203         -            set share 2 ;# FILE_SHARE_WRITE
   204         -        }
   205         -        readwrite  {
   206         -            set share 3
   207         -        }
   208         -    }
   209         -    
   210         -    return [CreateConsoleScreenBuffer \
   211         -                $mode \
   212         -                $share \
   213         -                [_make_secattr $opts(secd) $opts(inherit)] \
   214         -                1]
   215         -}
   216         -
   217         -# Retrieve information about a console screen buffer
   218         -proc twapi::_get_console_screen_buffer_info {conh args} {
   219         -    array set opts [parseargs args {
   220         -        all
   221         -        textattr
   222         -        cursorpos
   223         -        maxwindowsize
   224         -        size
   225         -        windowlocation
   226         -        windowpos
   227         -        windowsize
   228         -    } -maxleftover 0]
   229         -
   230         -    lassign [GetConsoleScreenBufferInfo $conh] size cursorpos textattr windowlocation maxwindowsize
   231         -
   232         -    set result [list ]
   233         -    foreach opt {size cursorpos maxwindowsize windowlocation} {
   234         -        if {$opts($opt) || $opts(all)} {
   235         -            lappend result -$opt [set $opt]
   236         -        }
   237         -    }
   238         -
   239         -    if {$opts(windowpos) || $opts(all)} {
   240         -        lappend result -windowpos [lrange $windowlocation 0 1]
   241         -    }
   242         -
   243         -    if {$opts(windowsize) || $opts(all)} {
   244         -        lassign $windowlocation left top right bot
   245         -        lappend result -windowsize [list [expr {$right-$left+1}] [expr {$bot-$top+1}]]
   246         -    }
   247         -
   248         -    if {$opts(textattr) || $opts(all)} {
   249         -        lappend result -textattr [_flags_to_console_output_attr $textattr]
   250         -    }
   251         -
   252         -    return $result
   253         -}
   254         -interp alias {} twapi::get_console_screen_buffer_info {} twapi::_do_console_proc twapi::_get_console_screen_buffer_info stdout
   255         -
   256         -# Set the cursor position
   257         -proc twapi::_set_console_cursor_position {conh pos} {
   258         -    SetConsoleCursorPosition $conh $pos
   259         -}
   260         -interp alias {} twapi::set_console_cursor_position {} twapi::_do_console_proc twapi::_set_console_cursor_position stdout
   261         -
   262         -# Get the cursor position
   263         -proc twapi::get_console_cursor_position {conh} {
   264         -    return [lindex [get_console_screen_buffer_info $conh -cursorpos] 1]
   265         -}
   266         -
   267         -# Write the specified string to the console
   268         -proc twapi::_console_write {conh s args} {
   269         -    # Note writes are always in raw mode, 
   270         -    # TBD - support for  scrolling
   271         -    # TBD - support for attributes
   272         -
   273         -    array set opts [parseargs args {
   274         -        position.arg
   275         -        {newlinemode.arg column {line column}}
   276         -        {restoreposition.bool 0}
   277         -    } -maxleftover 0]
   278         -
   279         -    # Get screen buffer info including cursor position
   280         -    array set csbi [get_console_screen_buffer_info $conh -cursorpos -size]
   281         -
   282         -    # Get current console mode for later restoration
   283         -    # If console is in processed mode, set it to raw mode
   284         -    set oldmode [get_console_output_mode $conh]
   285         -    set processed_index [lsearch -exact $oldmode "processed"]
   286         -    if {$processed_index >= 0} {
   287         -        # Console was in processed mode. Set it to raw mode
   288         -        set newmode [lreplace $oldmode $processed_index $processed_index]
   289         -        set_console_output_mode $conh $newmode
   290         -    }
   291         -    
   292         -    trap {
   293         -        # x,y are starting position to write
   294         -        if {[info exists opts(position)]} {
   295         -            lassign [_parse_integer_pair $opts(position)] x y
   296         -        } else {
   297         -            # No position specified, get current cursor position
   298         -            lassign $csbi(-cursorpos) x y
   299         -        }
   300         -        
   301         -        set startx [expr {$opts(newlinemode) == "column" ? $x : 0}]
   302         -
   303         -        # Get screen buffer limits
   304         -        lassign  $csbi(-size)  width height
   305         -
   306         -        # Ensure line terminations are just \n
   307         -        set s [string map [list \r\n \n] $s]
   308         -
   309         -        # Write out each line at ($x,$y)
   310         -        # Either \r or \n is considered a newline
   311         -        foreach line [split $s \r\n] {
   312         -            if {$y >= $height} break
   313         -            set_console_cursor_position $conh [list $x $y]
   314         -            if {$x < $width} {
   315         -                # Write the characters - do not write more than buffer width
   316         -                set num_chars [expr {$width-$x}]
   317         -                if {[string length $line] < $num_chars} {
   318         -                    set num_chars [string length $line]
   319         -                }
   320         -                WriteConsole $conh $line $num_chars
   321         -            }
   322         -            
   323         -            
   324         -            # Calculate starting position of next line
   325         -            incr y
   326         -            set x $startx
   327         -        }
   328         -
   329         -    } finally {
   330         -        # Restore cursor if requested
   331         -        if {$opts(restoreposition)} {
   332         -            set_console_cursor_position $conh $csbi(-cursorpos)
   333         -        }
   334         -        # Restore output mode if changed
   335         -        if {[info exists newmode]} {
   336         -            set_console_output_mode $conh $oldmode
   337         -        }
   338         -    }
   339         -
   340         -    return
   341         -}
   342         -interp alias {} twapi::write_console {} twapi::_do_console_proc twapi::_console_write stdout
   343         -interp alias {} twapi::console_write {} twapi::_do_console_proc twapi::_console_write stdout
   344         -
   345         -# Fill an area of the console with the specified attribute
   346         -proc twapi::_fill_console {conh args} {
   347         -    array set opts [parseargs args {
   348         -        position.arg
   349         -        numlines.int
   350         -        numcols.int
   351         -        {mode.arg column {line column}}
   352         -        window.bool
   353         -        fillchar.arg
   354         -    } -ignoreunknown]
   355         -
   356         -    # args will now contain attribute switches if any
   357         -    set attr [_console_output_attr_to_flags $args]
   358         -
   359         -    # Get screen buffer info for window and size of buffer
   360         -    array set csbi [get_console_screen_buffer_info $conh -windowpos -windowsize -size]
   361         -    # Height and width of the console
   362         -    lassign $csbi(-size) conx cony
   363         -
   364         -    # Figure out what area we want to fill
   365         -    # startx,starty are starting position to write
   366         -    # sizex, sizey are the number of rows/lines
   367         -    if {[info exists opts(window)]} {
   368         -        if {[info exists opts(numlines)] || [info exists opts(numcols)]
   369         -            || [info exists opts(position)]} {
   370         -            error "Option -window cannot be used togther with options -position, -numlines or -numcols"
   371         -        }
   372         -        lassign  [_parse_integer_pair $csbi(-windowpos)] startx starty
   373         -        lassign  [_parse_integer_pair $csbi(-windowsize)] sizex sizey
   374         -    } else {
   375         -        if {[info exists opts(position)]} {
   376         -            lassign [_parse_integer_pair $opts(position)] startx starty
   377         -        } else {
   378         -            set startx 0
   379         -            set starty 0
   380         -        }
   381         -        if {[info exists opts(numlines)]} {
   382         -            set sizey $opts(numlines)
   383         -        } else {
   384         -            set sizey $cony
   385         -        }
   386         -        if {[info exists opts(numcols)]} {
   387         -            set sizex $opts(numcols)
   388         -        } else {
   389         -            set sizex [expr {$conx - $startx}]
   390         -        }
   391         -    }
   392         -    
   393         -    set firstcol [expr {$opts(mode) == "column" ? $startx : 0}]
   394         -
   395         -    # Fill attribute at ($x,$y)
   396         -    set x $startx
   397         -    set y $starty
   398         -    while {$y < $cony && $y < ($starty + $sizey)} {
   399         -        if {$x < $conx} {
   400         -            # Write the characters - do not write more than buffer width
   401         -            set max [expr {$conx-$x}]
   402         -            if {[info exists attr]} {
   403         -                FillConsoleOutputAttribute $conh $attr [expr {$sizex > $max ? $max : $sizex}] [list $x $y]
   404         -            }
   405         -            if {[info exists opts(fillchar)]} {
   406         -                FillConsoleOutputCharacter $conh $opts(fillchar) [expr {$sizex > $max ? $max : $sizex}] [list $x $y]
   407         -            }
   408         -        }
   409         -        
   410         -        # Calculate starting position of next line
   411         -        incr y
   412         -        set x $firstcol
   413         -    }
   414         -    
   415         -    return
   416         -}
   417         -interp alias {} twapi::fill_console {} twapi::_do_console_proc twapi::_fill_console stdout
   418         -
   419         -# Clear the console
   420         -proc twapi::_clear_console {conh args} {
   421         -    # I support we could just call fill_console but this code was already
   422         -    # written and is faster
   423         -    array set opts [parseargs args {
   424         -        {fillchar.arg " "}
   425         -        {windowonly.bool 0}
   426         -    } -maxleftover 0]
   427         -
   428         -    array set cinfo [get_console_screen_buffer_info $conh -size -windowpos -windowsize]
   429         -    lassign  $cinfo(-size) width height
   430         -    if {$opts(windowonly)} {
   431         -        # Only clear portion visible in the window. We have to do this
   432         -        # line by line since we do not want to erase text scrolled off
   433         -        # the window either in the vertical or horizontal direction
   434         -        lassign $cinfo(-windowpos) x y
   435         -        lassign $cinfo(-windowsize) w h
   436         -        for {set i 0} {$i < $h} {incr i} {
   437         -            FillConsoleOutputCharacter \
   438         -                $conh \
   439         -                $opts(fillchar)  \
   440         -                $w \
   441         -                [list $x [expr {$y+$i}]]
   442         -        }
   443         -    } else {
   444         -        FillConsoleOutputCharacter \
   445         -            $conh \
   446         -            $opts(fillchar)  \
   447         -            [expr {($width*$height) }] \
   448         -            [list 0 0]
   449         -    }
   450         -    return
   451         -}
   452         -interp alias {} twapi::clear_console {} twapi::_do_console_proc twapi::_clear_console stdout
   453         -#
   454         -# Flush console input
   455         -proc twapi::_flush_console_input {conh} {
   456         -    FlushConsoleInputBuffer $conh
   457         -}
   458         -interp alias {} twapi::flush_console_input {} twapi::_do_console_proc twapi::_flush_console_input stdin
   459         -
   460         -# Return number of pending console input events
   461         -proc twapi::_get_console_pending_input_count {conh} {
   462         -    return [GetNumberOfConsoleInputEvents $conh]
   463         -}
   464         -interp alias {} twapi::get_console_pending_input_count {} twapi::_do_console_proc twapi::_get_console_pending_input_count stdin
   465         -
   466         -# Generate a console control event
   467         -proc twapi::generate_console_control_event {event {procgrp 0}} {
   468         -    switch -exact -- $event {
   469         -        ctrl-c {set event 0}
   470         -        ctrl-break {set event 1}
   471         -        default {error "Invalid event definition '$event'"}
   472         -    }
   473         -    GenerateConsoleCtrlEvent $event $procgrp
   474         -}
   475         -
   476         -# Get number of mouse buttons
   477         -proc twapi::num_console_mouse_buttons {} {
   478         -    return [GetNumberOfConsoleMouseButtons]
   479         -}
   480         -
   481         -# Get console title text
   482         -proc twapi::get_console_title {} {
   483         -    return [GetConsoleTitle]
   484         -}
   485         -
   486         -# Set console title text
   487         -proc twapi::set_console_title {title} {
   488         -    return [SetConsoleTitle $title]
   489         -}
   490         -
   491         -# Get the handle to the console window
   492         -proc twapi::get_console_window {} {
   493         -    return [GetConsoleWindow]
   494         -}
   495         -
   496         -# Get the largest console window size
   497         -proc twapi::_get_console_window_maxsize {conh} {
   498         -    return [GetLargestConsoleWindowSize $conh]
   499         -}
   500         -interp alias {} twapi::get_console_window_maxsize {} twapi::_do_console_proc twapi::_get_console_window_maxsize stdout
   501         -
   502         -proc twapi::_set_console_active_screen_buffer {conh} {
   503         -    SetConsoleActiveScreenBuffer $conh
   504         -}
   505         -interp alias {} twapi::set_console_active_screen_buffer {} twapi::_do_console_proc twapi::_set_console_active_screen_buffer stdout
   506         -
   507         -# Set the size of the console screen buffer
   508         -proc twapi::_set_console_screen_buffer_size {conh size} {
   509         -    SetConsoleScreenBufferSize $conh [_parse_integer_pair $size]
   510         -}
   511         -interp alias {} twapi::set_console_screen_buffer_size {} twapi::_do_console_proc twapi::_set_console_screen_buffer_size stdout
   512         -
   513         -# Set the default text attribute
   514         -proc twapi::_set_console_default_attr {conh args} {
   515         -    SetConsoleTextAttribute $conh [_console_output_attr_to_flags $args]
   516         -}
   517         -interp alias {} twapi::set_console_default_attr {} twapi::_do_console_proc twapi::_set_console_default_attr stdout
   518         -
   519         -# Set the console window position
   520         -proc twapi::_set_console_window_location {conh rect args} {
   521         -    array set opts [parseargs args {
   522         -        {absolute.bool true}
   523         -    } -maxleftover 0]
   524         -
   525         -    SetConsoleWindowInfo $conh $opts(absolute) $rect
   526         -}
   527         -interp alias {} twapi::set_console_window_location {} twapi::_do_console_proc twapi::_set_console_window_location stdout
   528         -
   529         -proc twapi::get_console_window_location {conh} {
   530         -    return [lindex [get_console_screen_buffer_info $conh -windowlocation] 1]
   531         -}
   532         -
   533         -# Get the console code page
   534         -proc twapi::get_console_output_codepage {} {
   535         -    return [GetConsoleOutputCP]
   536         -}
   537         -
   538         -# Set the console code page
   539         -proc twapi::set_console_output_codepage {cp} {
   540         -    SetConsoleOutputCP $cp
   541         -}
   542         -
   543         -# Get the console input code page
   544         -proc twapi::get_console_input_codepage {} {
   545         -    return [GetConsoleCP]
   546         -}
   547         -
   548         -# Set the console input code page
   549         -proc twapi::set_console_input_codepage {cp} {
   550         -    SetConsoleCP $cp
   551         -}
   552         -
   553         -# Read a line of input
   554         -proc twapi::_console_read {conh args} {
   555         -    if {[llength $args]} {
   556         -        set oldmode [modify_console_input_mode $conh {*}$args]
   557         -    }
   558         -    trap {
   559         -        return [ReadConsole $conh 1024]
   560         -    } finally {
   561         -        if {[info exists oldmode]} {
   562         -            set_console_input_mode $conh {*}$oldmode
   563         -        }
   564         -    }
   565         -}
   566         -interp alias {} twapi::console_read {} twapi::_do_console_proc twapi::_console_read stdin
   567         -
   568         -proc twapi::_map_console_controlkeys {control} {
   569         -    return [_make_symbolic_bitmask $control {
   570         -        capslock 0x80
   571         -        enhanced 0x100
   572         -        leftalt 0x2
   573         -        leftctrl 0x8
   574         -        numlock 0x20
   575         -        rightalt 0x1
   576         -        rightctrl 4
   577         -        scrolllock 0x40
   578         -        shift 0x10
   579         -    } 0]
   580         -}
   581         -
   582         -proc twapi::_console_read_input_records {conh args} {
   583         -    parseargs args {
   584         -        {count.int 1}
   585         -        peek
   586         -    } -setvars -maxleftover 0
   587         -    set recs {}
   588         -    if {$peek} {
   589         -        set input [PeekConsoleInput $conh $count]
   590         -    } else {
   591         -        set input [ReadConsoleInput $conh $count]
   592         -    }
   593         -    foreach rec $input {
   594         -        switch [format %d [lindex $rec 0]] {
   595         -            1 {
   596         -                lassign [lindex $rec 1] keydown repeat keycode scancode char controlstate
   597         -                lappend recs \
   598         -                    [list key [list \
   599         -                                   keystate [expr {$keydown ? "down" : "up"}] \
   600         -                                   repeat $repeat keycode $keycode \
   601         -                                   scancode $scancode char $char \
   602         -                                   controls [_map_console_controlkeys $controlstate]]]
   603         -            }
   604         -            2 {
   605         -                lassign [lindex $rec 1] position buttonstate controlstate flags
   606         -                set buttons {}
   607         -                if {[expr {$buttonstate & 0x1}]} {lappend buttons left}
   608         -                if {[expr {$buttonstate & 0x2}]} {lappend buttons right}
   609         -                if {[expr {$buttonstate & 0x4}]} {lappend buttons left2}
   610         -                if {[expr {$buttonstate & 0x8}]} {lappend buttons left3}
   611         -                if {[expr {$buttonstate & 0x10}]} {lappend buttons left4}
   612         -                if {$flags & 0x8} {
   613         -                    set horizontalwheel [expr {$buttonstate >> 16}]
   614         -                } else {
   615         -                    set horizontalwheel 0
   616         -                }
   617         -                if {$flags & 0x4} {
   618         -                    set verticalwheel [expr {$buttonstate >> 16}]
   619         -                } else {
   620         -                    set verticalwheel 0
   621         -                }
   622         -                lappend recs \
   623         -                    [list mouse [list \
   624         -                                     position $position \
   625         -                                     buttons $buttons \
   626         -                                     controls [_map_console_controlkeys $controlstate] \
   627         -                                     doubleclick [expr {$flags & 0x2}] \
   628         -                                     horizontalwheel $horizontalwheel \
   629         -                                     moved [expr {$flags & 0x1}] \
   630         -                                     verticalwheel $verticalwheel]]
   631         -            }
   632         -            default {
   633         -                lappend recs [list \
   634         -                                  [dict* {4 buffersize 8 menu 16 focus} [lindex $rec 0]] \
   635         -                                  [lindex $rec 1]]
   636         -            }
   637         -        }
   638         -    }
   639         -    return $recs
   640         -}
   641         -interp alias {} twapi::console_read_input_records {} twapi::_do_console_proc twapi::_console_read_input_records stdin
   642         -
   643         -# Set up a console handler
   644         -proc twapi::_console_ctrl_handler {ctrl} {
   645         -    variable _console_control_script
   646         -    if {[info exists _console_control_script]} {
   647         -        return [uplevel #0 [linsert $_console_control_script end $ctrl]]
   648         -    }
   649         -    return 0;                   # Not handled
   650         -}
   651         -proc twapi::set_console_control_handler {script} {
   652         -    variable _console_control_script
   653         -    if {[string length $script]} {
   654         -        if {![info exists _console_control_script]} {
   655         -            Twapi_ConsoleEventNotifier 1
   656         -        }
   657         -        set _console_control_script $script
   658         -    } else {
   659         -        if {[info exists _console_control_script]} {
   660         -            Twapi_ConsoleEventNotifier 0
   661         -            unset _console_control_script
   662         -        }
   663         -    }
   664         -}
   665         -
   666         -# 
   667         -# Utilities
   668         -#
   669         -
   670         -# Helper to call a proc after doing a stdin/stdout/stderr -> handle
   671         -# mapping. The handle is closed after calling the proc. The first
   672         -# arg in $args must be the console handle if $args is not an empty list
   673         -proc twapi::_do_console_proc {proc default args} {
   674         -    if {[llength $args] == 0} {
   675         -        set args [list $default]
   676         -    }
   677         -    set conh [lindex $args 0]
   678         -    switch -exact -- [string tolower $conh] {
   679         -        stdin  -
   680         -        stdout -
   681         -        stderr {
   682         -            set real_handle [get_console_handle $conh]
   683         -            trap {
   684         -                lset args 0 $real_handle
   685         -                return [uplevel 1 [list $proc] $args]
   686         -            } finally {
   687         -                CloseHandle $real_handle
   688         -            }
   689         -        }
   690         -    }
   691         -    
   692         -    return [uplevel 1 [list $proc] $args]
   693         -}
   694         -
   695         -proc twapi::_console_input_mode_syms {} {
   696         -    return {
   697         -        -processedinput 0x0001
   698         -        -lineinput      0x0002
   699         -        -echoinput      0x0004
   700         -        -windowinput    0x0008
   701         -        -mouseinput     0x0010
   702         -        -insertmode     0x0020
   703         -        -quickeditmode  0x0040
   704         -        -extendedmode   0x0080
   705         -        -autoposition   0x0100
   706         -    }
   707         -}
   708         -
   709         -proc twapi::_console_output_mode_syms {} {
   710         -    return { -processedoutput 1 -wrapoutput 2 }
   711         -}
   712         -
   713         -twapi::proc* twapi::_console_output_attr {sym} {
   714         -    variable _console_output_attr_syms
   715         -    array set _console_output_attr_syms {
   716         -        -fgblue 1
   717         -        -fggreen 2
   718         -        -fgturquoise 3
   719         -        -fgred 4
   720         -        -fgpurple 5
   721         -        -fgyellow 6
   722         -        -fggray 7
   723         -        -fgbright 8
   724         -        -fgwhite 15
   725         -        -bgblue 16
   726         -        -bggreen 32
   727         -        -bgturquoise 48
   728         -        -bgred 64
   729         -        -bgpurple 80
   730         -        -bgyellow 96
   731         -        -bggray 112
   732         -        -bgbright 128
   733         -        -bgwhite 240
   734         -    }
   735         -} {
   736         -    variable _console_output_attr_syms
   737         -    if {[info exists _console_output_attr_syms($sym)]} {
   738         -        return $_console_output_attr_syms($sym)
   739         -    }
   740         -
   741         -    badargs! "Invalid console output attribute '$sym'" 3
   742         -}
   743         -

Deleted winlibs/twapi/crypto.tcl.

     1         -#
     2         -# Copyright (c) 2007-2014, Ashok P. Nadkarni
     3         -# All rights reserved.
     4         -#
     5         -# See the file LICENSE for license
     6         -
     7         -namespace eval twapi {}
     8         -
     9         -### Data protection
    10         -
    11         -proc twapi::protect_data {data args} {
    12         -
    13         -    # Not used because doesn't seem to have any effect 
    14         -    # {promptonunprotect.bool 0 0x1}
    15         -    parseargs args {
    16         -        {description.arg ""}
    17         -        {localmachine.bool 0 0x4}
    18         -        {noui.bool 0 0x1}
    19         -        {audit.bool 0 0x10}
    20         -        {hwnd.arg NULL}
    21         -        prompt.arg
    22         -    } -setvars -maxleftover 0
    23         -
    24         -    if {[info exists prompt]} {
    25         -        # 2 -> PROMPTONPROTECT
    26         -        set prompt [list 2 $hwnd $prompt]
    27         -    } else {
    28         -        set prompt {}
    29         -    }
    30         -
    31         -    return [CryptProtectData $data $description "" "" $prompt [expr {$localmachine | $noui | $audit}]]
    32         -}
    33         -
    34         -proc twapi::unprotect_data {data args} {
    35         -    # Do not seem to have any effect
    36         -    # {promptonunprotect.bool 0 0x1}
    37         -    # {promptonprotect.bool 0 0x2}
    38         -    parseargs args {
    39         -        {withdescription.bool 0}
    40         -        {noui.bool 0 0x1}
    41         -        {hwnd.arg NULL}
    42         -        prompt.arg
    43         -    } -setvars -maxleftover 0
    44         -
    45         -    if {[info exists prompt]} {
    46         -        # 2 -> PROMPTONPROTECT
    47         -        set prompt [list 2 $hwnd $prompt]
    48         -    } else {
    49         -        set prompt {}
    50         -    }
    51         -
    52         -    set data [CryptUnprotectData $data "" "" $prompt $noui]
    53         -    if {$withdescription} {
    54         -        return $data
    55         -    } else {
    56         -        return [lindex $data 0]
    57         -    }
    58         -}
    59         -
    60         -
    61         -
    62         -################################################################
    63         -# Certificate Stores
    64         -
    65         -# Close a certificate store
    66         -proc twapi::cert_store_release {hstore} {
    67         -    CertCloseStore $hstore 0
    68         -    return
    69         -}
    70         -
    71         -proc twapi::cert_temporary_store {args} {
    72         -    parseargs args {
    73         -        {encoding.arg der {der cer crt pem base64}}
    74         -        serialized.arg
    75         -        pkcs7.arg
    76         -        {password.arg ""}
    77         -        pfx.arg
    78         -        pkcs12.arg
    79         -        {exportableprivatekeys.bool 0 1}
    80         -        {userprotected.bool 0 2}
    81         -        keysettype.arg
    82         -    } -setvars -maxleftover 0
    83         -    
    84         -    set nformats 0
    85         -    foreach format {serialized pkcs7 pfx pkcs12} {
    86         -        if {[info exists $format]} {
    87         -            set data [set $format]
    88         -            incr nformats
    89         -        }
    90         -    }
    91         -    if {$nformats > 1} {
    92         -        badargs! "At most one of -pfx, -pkcs12, -pkcs7 or -serialized may be specified."
    93         -    }
    94         -    if {$nformats == 0} {
    95         -        # 2 -> CERT_STORE_PROV_MEMORY 
    96         -        return [CertOpenStore 2 0 NULL 0 ""]
    97         -    }
    98         -    
    99         -    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
   100         -
   101         -    if {[info exists serialized]} {
   102         -        # 6 -> CERT_STORE_PROV_SERIALIZED
   103         -        return [CertOpenStore 6 0x10001 NULL 0 $data]
   104         -    }
   105         -
   106         -    if {[info exists pkcs7]} {
   107         -        if {$encoding in {pem base64}} {
   108         -            # 6 -> CRYPT_STRING_BASE64_ANY 
   109         -            set data [CryptStringToBinary $data 6]
   110         -        }
   111         -        # 5 -> CERT_STORE_PROV_PKCS7
   112         -        return [CertOpenStore 5 0x10001 NULL 0 $data]
   113         -    }
   114         -
   115         -    # PFX/PKCS12
   116         -    if {[string length $password] == 0} {
   117         -        set password [conceal ""]
   118         -    }
   119         -    set flags 0
   120         -    if {[info exists keysettype]} {
   121         -        set flags [dict! {user 0x1000 machine 0x20} $keysettype]
   122         -    }
   123         -
   124         -    set flags [tcl::mathop::| $flags $exportableprivatekeys $userprotected]
   125         -    return [PFXImportCertStore $data $password $flags]
   126         -}
   127         -
   128         -proc twapi::cert_file_store_open {path args} {
   129         -    set flags [_parse_store_open_opts $args]
   130         -
   131         -    if {! ($flags & 0x00008000)} {
   132         -        # If not readonly, set commitenable
   133         -        set flags [expr {$flags | 0x00010000}]
   134         -    }
   135         -
   136         -    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
   137         -    # 8 -> CERT_STORE_PROV_FILENAME_W
   138         -    return [CertOpenStore 8 0x10001 NULL $flags [file nativename [file normalize $path]]]
   139         -}
   140         -
   141         -proc twapi::cert_serialized_store_open {data args} {
   142         -    set flags [_parse_store_open_opts $args]
   143         -
   144         -    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
   145         -    # 6 -> CERT_STORE_PROV_SERIALIZED
   146         -    return [CertOpenStore 6 0x10001 NULL $flags $data]
   147         -}
   148         -
   149         -
   150         -
   151         -proc twapi::cert_physical_store_open {name location args} {
   152         -    variable _system_stores
   153         -
   154         -    set flags [_parse_store_open_opts $args]
   155         -    incr flags [_system_store_id $location]
   156         -    # 14 -> CERT_STORE_PROV_PHYSICAL_W
   157         -    return [CertOpenStore 14 0 NULL $flags $name]
   158         -}
   159         -
   160         -proc twapi::cert_physical_store_delete {name location} {
   161         -    set flags 0x10;             # CERT_STORE_DELETE_FLAG
   162         -    incr flags [_system_store_id $location]
   163         -    
   164         -    # 14 -> CERT_STORE_PROV_PHYSICAL_W
   165         -    return [CertOpenStore 14 0 NULL $flags $name]
   166         -}
   167         -
   168         -# TBD - document and figure out what format to return data in
   169         -proc twapi::cert_physical_stores {system_store_name location} {
   170         -    return [CertEnumPhysicalStore $system_store_name [_system_store_id $location]]
   171         -}
   172         -
   173         -proc twapi::cert_system_store_open {name args} {
   174         -    variable _system_stores
   175         -
   176         -    if {[llength $args] == 0} {
   177         -        return [CertOpenSystemStore $name]
   178         -    }
   179         -
   180         -    set flags [_parse_store_open_opts [lassign $args location]]
   181         -    incr flags [_system_store_id $location]
   182         -    return [CertOpenStore 10 0 NULL $flags $name]
   183         -}
   184         -
   185         -proc twapi::cert_system_store_delete {name location} {
   186         -    set flags 0x10;             # CERT_STORE_DELETE_FLAG
   187         -    incr flags [_system_store_id $location]
   188         -    return [CertOpenStore 10 0 NULL $flags $name]
   189         -}
   190         -
   191         -proc twapi::cert_system_store_locations {} {
   192         -    set l {}
   193         -    foreach e [CertEnumSystemStoreLocation 0] {
   194         -        lappend l [lindex $e 0]
   195         -    }
   196         -    return $l
   197         -}
   198         -
   199         -proc twapi::cert_system_stores {location} {
   200         -    set l {}
   201         -    foreach e [CertEnumSystemStore [_system_store_id $location] ""] {
   202         -        lappend l [lindex $e 0]
   203         -    }
   204         -    return $l
   205         -}
   206         -
   207         -# TBD - document?
   208         -proc twapi::cert_store_iterate {hstore varname script {type any} {term {}}} {
   209         -    upvar 1 $varname cert
   210         -    set cert NULL
   211         -    while {1} {
   212         -        set cert [cert_store_find_certificate $hstore $type $term $cert]
   213         -        if {$cert eq ""} break
   214         -        switch [catch {uplevel 1 $script} result options] {
   215         -            0 -
   216         -            4 {}
   217         -            3 {
   218         -                cert_release $cert
   219         -                set cert ""
   220         -                return
   221         -            }
   222         -            1 -
   223         -            default {
   224         -                cert_release $cert
   225         -                set cert ""
   226         -                return -options $options $result
   227         -            }
   228         -        }
   229         -    }
   230         -    return
   231         -}
   232         -
   233         -proc twapi::cert_store_find_certificate {hstore {type any} {term {}} {hcert NULL}} {
   234         -
   235         -    # TBD subject_cert 11<<16
   236         -    # TBD key_spec 9<<16
   237         -
   238         -    set term_types {
   239         -        any 0
   240         -        existing 13<<16
   241         -        key_identifier 15<<16
   242         -        md5_hash 4<<16
   243         -        subject_public_key_md5_hash 18<<16
   244         -        sha1_hash 1<<16
   245         -        signature_hash 14<<16
   246         -        issuer_name (2<<16)|4
   247         -        subject_name  (2<<16)|7
   248         -        issuer_substring (8<<16)|4
   249         -        subject_substring (8<<16)|7
   250         -        property 5<<16
   251         -        public_key 6<<16
   252         -    }
   253         -
   254         -    if {$type eq "property"} {
   255         -        set term [_cert_prop_id $term]
   256         -    }
   257         -    set type [expr [dict! $term_types $type 1]]
   258         -
   259         -    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
   260         -    return [CertFindCertificateInStore $hstore 0x10001 0 $type $term $hcert]
   261         -}
   262         -
   263         -proc twapi::cert_store_enum_contents {hstore {hcert NULL}} {
   264         -    return [CertEnumCertificatesInStore $hstore $hcert]
   265         -}
   266         -
   267         -proc twapi::cert_store_add_certificate {hstore hcert args} {
   268         -    array set opts [_cert_add_parseargs args]
   269         -    return [CertAddCertificateContextToStore $hstore $hcert $opts(disposition)]
   270         -}
   271         -
   272         -proc twapi::cert_store_add_encoded_certificate {hstore enccert args} {
   273         -    parseargs args {
   274         -        {encoding.arg der {der pem}}
   275         -    } -ignoreunknown -setvars
   276         -    array set opts [_cert_add_parseargs args]
   277         -    if {$encoding eq "pem"} {
   278         -        # 6 -> CRYPT_STRING_BASE64_ANY 
   279         -        set enccert [CryptStringToBinary $enccert 6]
   280         -    }
   281         -    return [CertAddEncodedCertificateToStore $hstore 0x10001 $enccert $opts(disposition)]
   282         -}
   283         -
   284         -proc twapi::cert_store_export_pfx {hstore password args} {
   285         -    parseargs args {
   286         -        {exportprivatekeys.bool 0 0x4}
   287         -        {failonmissingkey.bool 0 0x1}
   288         -        {failonunexportablekey.bool 0 0x2}
   289         -    } -maxleftover 0 -setvars
   290         -
   291         -    if {[string length $password] == 0} {
   292         -        set password [conceal ""]
   293         -    }
   294         -
   295         -    # NOTE: the -fail* flags only take effect iff the certificate in the store
   296         -    # claims to have a private key but does not actually have one. It will
   297         -    # not fail if the cert does not actually claim to have a private key
   298         -
   299         -    set flags [tcl::mathop::| $exportprivatekeys $failonunexportablekey $failonmissingkey]
   300         -
   301         -    return [PFXExportCertStoreEx $hstore $password {} $flags]
   302         -}
   303         -interp alias {} twapi::cert_store_export_pkcs12 {} twapi::cert_store_export_pfx
   304         -
   305         -proc twapi::cert_store_commit {hstore args} {
   306         -    array set opts [parseargs args {
   307         -        {force.bool 0}
   308         -    } -maxleftover 0]
   309         -    
   310         -    return [Twapi_CertStoreCommit $hstore $opts(force)]
   311         -}
   312         -
   313         -proc twapi::cert_store_serialize {hstore} {
   314         -    return [Twapi_CertStoreSerialize $hstore 1]
   315         -}
   316         -
   317         -proc twapi::cert_store_export_pkcs7 {hstore args} {
   318         -    parseargs args {
   319         -        {encoding.arg der {der pem}}
   320         -    } -setvars -maxleftover 0
   321         -    
   322         -    set exp [Twapi_CertStoreSerialize $hstore 2]
   323         -    if {$encoding eq "pem"} {
   324         -        # 1 -> CRYPT_STRING_BASE64
   325         -        # 0x80000000 -> LF-only, not CRLF
   326         -        return "-----BEGIN PKCS7-----\n[CryptBinaryToString $exp 0x80000001]-----END PKCS7-----\n"
   327         -    } else {
   328         -        return $exp
   329         -    }
   330         -}
   331         -
   332         -################################################################
   333         -# Certificates
   334         -
   335         -interp alias {} twapi::cert_subject_name {} twapi::_cert_get_name subject
   336         -interp alias {} twapi::cert_issuer_name {} twapi::_cert_get_name issuer
   337         -proc twapi::_cert_get_name {field hcert args} {
   338         -
   339         -    switch $field {
   340         -        subject { set field 0 }
   341         -        issuer  { set field 1 }
   342         -        default { badargs! "Invalid name type '$field': must be \"subject\" or \"issuer\"."
   343         -        }
   344         -    }
   345         -    array set opts [parseargs args {
   346         -        {name.arg oid_common_name}
   347         -        {separator.arg comma {comma semicolon newline}}
   348         -        {reverse.bool 0 0x02000000}
   349         -        {noquote.bool 0 0x10000000}
   350         -        {noplus.bool  0 0x20000000}
   351         -        {format.arg x500 {x500 oid simple}}
   352         -    } -maxleftover 0]
   353         -
   354         -    set arg ""
   355         -    switch $opts(name) {
   356         -        email { set what 1 }
   357         -        simpledisplay { set what 4 }
   358         -        friendlydisplay {set what 5 }
   359         -        dns { set what 6 }
   360         -        url { set what 7 }
   361         -        upn { set what 8 }
   362         -        rdn {
   363         -            set what 2
   364         -            switch $opts(format) {
   365         -                simple {set arg 1}
   366         -                oid {set arg 2}
   367         -                x500 -
   368         -                default {set arg 3}
   369         -            }
   370         -            set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}]
   371         -            switch $opts(separator) {
   372         -                semicolon    { set arg [expr {$arg | 0x40000000}] }
   373         -                newline { set arg [expr {$arg | 0x08000000}] }
   374         -            }
   375         -        }
   376         -        default {
   377         -            set what 3;         # Assume OID
   378         -            set arg [oid $opts(name)]
   379         -        }
   380         -    }
   381         -
   382         -    return [CertGetNameString $hcert $what $field $arg]
   383         -
   384         -}
   385         -
   386         -proc twapi::cert_blob_to_name {blob args} {
   387         -    array set opts [parseargs args {
   388         -        {format.arg x500 {x500 oid simple}}
   389         -        {separator.arg comma {comma semi newline}}
   390         -        {reverse.bool 0 0x02000000}
   391         -        {noquote.bool 0 0x10000000}
   392         -        {noplus.bool  0 0x20000000}
   393         -    } -maxleftover 0]
   394         -
   395         -    switch $opts(format) {
   396         -        x500   {set arg 3}
   397         -        simple {set arg 1}
   398         -        oid    {set arg 2}
   399         -    }
   400         -
   401         -    set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}]
   402         -    switch $opts(separator) {
   403         -        semi    { set arg [expr {$arg | 0x40000000}] }
   404         -        newline { set arg [expr {$arg | 0x08000000}] }
   405         -    }
   406         -
   407         -    return [CertNameToStr $blob $arg]
   408         -}
   409         -
   410         -proc twapi::cert_name_to_blob {name args} {
   411         -    array set opts [parseargs args {
   412         -        {format.arg x500 {x500 oid simple}}
   413         -        {separator.arg any {any comma semicolon newline}}
   414         -        {reverse.bool 0 0x02000000}
   415         -        {noquote.bool 0 0x10000000}
   416         -        {noplus.bool  0 0x20000000}
   417         -    } -maxleftover 0]
   418         -
   419         -    switch $opts(format) {
   420         -        x500   {set arg 3}
   421         -        simple {set arg 1}
   422         -        oid    {set arg 2}
   423         -    }
   424         -
   425         -    set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}]
   426         -    switch $opts(separator) {
   427         -        comma   { set arg [expr {$arg | 0x04000000}] }
   428         -        semicolon    { set arg [expr {$arg | 0x40000000}] }
   429         -        newline { set arg [expr {$arg | 0x08000000}] }
   430         -    }
   431         -
   432         -    return [CertStrToName $name $arg]
   433         -}
   434         -
   435         -proc twapi::cert_enum_properties {hcert args} {
   436         -    parseargs args {
   437         -        names
   438         -    } -setvars -maxleftover 0
   439         -    
   440         -    set id 0
   441         -    set ids {}
   442         -    while {[set id [CertEnumCertificateContextProperties $hcert $id]]} {
   443         -        if {$names} {
   444         -            lappend ids [_cert_prop_name $id]
   445         -        } else {
   446         -            lappend ids $id
   447         -        }
   448         -    }
   449         -    return $ids
   450         -}
   451         -
   452         -proc twapi::cert_property {hcert prop} {
   453         -    # TBD - need to cook some properties - enhkey_usage
   454         -
   455         -    if {[string is integer -strict $prop]} {
   456         -        return [CertGetCertificateContextProperty $hcert $prop]
   457         -    } else {
   458         -        return [CertGetCertificateContextProperty $hcert [_cert_prop_id $prop] 1]
   459         -    }
   460         -}
   461         -
   462         -proc twapi::cert_property_set {hcert prop propval} {
   463         -    switch $prop {
   464         -        pvk_file -
   465         -        friendly_name -
   466         -        description {
   467         -            set val [encoding convertto unicode "${propval}\0"]
   468         -        }
   469         -        enhkey_usage {
   470         -            set val [::twapi::CryptEncodeObjectEx 2.5.29.37 [_get_enhkey_usage_oids $propval]]
   471         -        }
   472         -        default {
   473         -            badargs! "Invalid or unsupported property name \"$prop\". Must be one of [join $unicode_props {, }]."
   474         -        }
   475         -    }
   476         -
   477         -    CertSetCertificateContextProperty $hcert [_cert_prop_id $prop] 0 $val
   478         -}
   479         -
   480         -proc twapi::cert_property_delete {hcert prop} {
   481         -    CertSetCertificateContextProperty $hcert [_cert_prop_id $prop] 0
   482         -}
   483         -
   484         -# TBD - Also add cert_set_key_prov_from_crypt_context
   485         -proc twapi::cert_set_key_prov {hcert args} {
   486         -    # TB - make keycontainer explicit arg
   487         -    parseargs args {
   488         -        keycontainer.arg
   489         -        csp.arg
   490         -        {csptype.arg prov_rsa_full}
   491         -        {keysettype.arg user {user machine}}
   492         -        {silent.bool 0 0x40}
   493         -        {keyspec.arg signature {keyexchange signature}}
   494         -    } -maxleftover 0 -nulldefault -setvars
   495         -
   496         -    set flags $silent
   497         -    if {$keysettype eq "machine"} {
   498         -        incr flags 0x20;        # CRYPT_KEYSET_MACHINE
   499         -    }
   500         -
   501         -    # TBD - does the keyspec matter ? In case of self signed cert
   502         -    # which (keyexchange/signature) or both have to be specified ?
   503         -
   504         -    # 2 -> CERT_KEY_PROV_INFO_PROP_ID
   505         -    # TBD - the provider param is hardcoded as {}. Should that be an option ?
   506         -    CertSetCertificateContextProperty $hcert 2 0 \
   507         -        [list $keycontainer $csp [_csp_type_name_to_id $csptype] $flags {} [_crypt_keyspec $keyspec]]
   508         -    return
   509         -}
   510         -
   511         -proc twapi::cert_export {hcert args} {
   512         -    parseargs args {
   513         -        {encoding.arg der {der pem}}
   514         -    } -maxleftover 0 -setvars
   515         -
   516         -    set enc [lindex [Twapi_CertGetEncoded $hcert] 1]
   517         -    if {$encoding eq "pem"} {
   518         -        # 0 -> CRYPT_STRING_BASE64HEADER 
   519         -        # 0x80000000 -> LF-only, not CRLF
   520         -        return [CryptBinaryToString $enc 0x80000000]
   521         -    } else {
   522         -        return $enc
   523         -    }
   524         -}
   525         -
   526         -proc twapi::cert_import {enccert args} {
   527         -    parseargs args {
   528         -        {encoding.arg der {der pem}}
   529         -    } -maxleftover 0 -setvars
   530         -
   531         -    if {$encoding eq "pem"} {
   532         -        # 6 -> CRYPT_STRING_BASE64_ANY 
   533         -        set enccert [CryptStringToBinary $enccert 6]
   534         -    }
   535         -
   536         -    return [CertCreateCertificateContext 0x10001 $enccert]
   537         -}
   538         -
   539         -
   540         -proc twapi::cert_enhkey_usage {hcert {loc both}} {
   541         -    return [_cert_decode_enhkey [CertGetEnhancedKeyUsage $hcert [dict! {property 4 extension 2 both 0} $loc 1]]]
   542         -}
   543         -
   544         -proc twapi::cert_key_usage {hcert} {
   545         -    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
   546         -    return [_cert_decode_keyusage [Twapi_CertGetIntendedKeyUsage 0x10001 $hcert]]
   547         -}
   548         -
   549         -proc twapi::cert_thumbprint {hcert} {
   550         -    binary scan [cert_property $hcert sha1_hash] H* hash
   551         -    return $hash
   552         -}
   553         -
   554         -proc twapi::cert_info {hcert} {
   555         -    return [twine {
   556         -        -version -serialnumber -signaturealgorithm -issuer
   557         -        -start -end -subject -publickey -issuerid -subjectid -extensions} \
   558         -                [Twapi_CertGetInfo $hcert]]
   559         -}
   560         -
   561         -proc twapi::cert_extension {hcert oid} {
   562         -    set ext [CertFindExtension $hcert [oid $oid]]
   563         -    if {[llength $ext] == 0} {
   564         -        return $ext
   565         -    }
   566         -    lassign $ext oid critical val
   567         -    return [list $critical [_cert_decode_extension $oid $val]]
   568         -}
   569         -
   570         -proc twapi::cert_create_self_signed {subject args} {
   571         -    set args [_cert_create_parse_options $args opts]
   572         -
   573         -    # TBD - make keycontainer explicit arg
   574         -    array set opts [parseargs args {
   575         -        {keyspec.arg signature {keyexchange signature}}
   576         -        {keycontainer.arg {}}
   577         -        {keysettype.arg user {machine user}}
   578         -        {silent.bool 0 0x40}
   579         -        {csp.arg {}}
   580         -        {csptype.arg {prov_rsa_full}}
   581         -        {signaturealgorithm.arg {}}
   582         -    } -maxleftover 0 -ignoreunknown]
   583         -
   584         -    set name_blob [cert_name_to_blob $subject]
   585         -
   586         -    set kiflags $opts(silent)
   587         -    if {$opts(keysettype) eq "machine"} {
   588         -        incr kiflags 0x20;  # CRYPT_MACHINE_KEYSET
   589         -    }
   590         -    set keyinfo [list \
   591         -                     $opts(keycontainer) \
   592         -                     $opts(csp) \
   593         -                     [_csp_type_name_to_id $opts(csptype)] \
   594         -                     $kiflags \
   595         -                     {} \
   596         -                     [_crypt_keyspec $opts(keyspec)]]
   597         -    
   598         -    set flags 0;                # Always 0 for now
   599         -    return [CertCreateSelfSignCertificate NULL $name_blob $flags $keyinfo \
   600         -                [_make_algorithm_identifier $opts(signaturealgorithm)] \
   601         -                $opts(start) $opts(end) $opts(extensions)]
   602         -}
   603         -
   604         -proc twapi::cert_create_self_signed_from_crypt_context {subject hprov args} {
   605         -    set args [_cert_create_parse_options $args opts]
   606         -
   607         -    array set opts [parseargs args {
   608         -        {signaturealgorithm.arg {}}
   609         -    } -maxleftover 0]
   610         -
   611         -    set name_blob [cert_name_to_blob $subject]
   612         -
   613         -    set flags 0;                # Always 0 for now
   614         -    return [CertCreateSelfSignCertificate $hprov $name_blob $flags {} \
   615         -                [_make_algorithm_identifier $opts(signaturealgorithm)] \
   616         -                $opts(start) $opts(end) $opts(extensions)]
   617         -}
   618         -
   619         -proc twapi::cert_create {subject pubkey cissuer args} {
   620         -    set args [_cert_create_parse_options $args opts]
   621         -
   622         -    parseargs args {
   623         -        {keyspec.arg signature {keyexchange signature}}
   624         -        {encoding.arg der {der pem}}
   625         -    } -maxleftover 0 -setvars
   626         -    
   627         -    # TBD - check that issuer is a CA
   628         -
   629         -    set issuer_info [cert_info $cissuer]
   630         -    set issuer_blob [cert_name_to_blob [dict get $issuer_info -subject] -format x500]
   631         -    set sigalgo [dict get $issuer_info -signaturealgorithm]
   632         -
   633         -    # If issuer cert has altnames, use they as issuer altnames for new cert
   634         -    set issuer_altnames [lindex [cert_extension $cissuer 2.5.29.17] 1]
   635         -    if {[llength $issuer_altnames]} {
   636         -        lappend opts(extensions) [_make_altnames_ext $issuer_altnames 0 1]
   637         -    }
   638         -
   639         -    # The subject key id in issuer's cert will become the
   640         -    # authority key id in the new cert
   641         -    # TBD - if fail, get the CERT_KEY_IDENTIFIER_PROP_ID
   642         -    # 2.5.29.14 -> oid_subject_key_identifier
   643         -    set issuer_subject_key_id [cert_extension $cissuer 2.5.29.14]
   644         -    if {[string length [lindex $issuer_subject_key_id 1]] } {
   645         -        # 2.5.29.35 -> oid_authority_key_identifier
   646         -        lappend opts(extensions) [list 2.5.29.35 0 [list [lindex $issuer_subject_key_id 1] {} {}]]
   647         -    }
   648         -
   649         -    # Generate a subject key identifier for this cert based on a hash
   650         -    # of the public key
   651         -    set subject_key_id [Twapi_HashPublicKeyInfo $pubkey]
   652         -    lappend opts(extensions) [list 2.5.29.14 0 $subject_key_id]
   653         -
   654         -    set start [timelist_to_large_system_time $opts(start)]
   655         -    set end [timelist_to_large_system_time $opts(end)]
   656         -
   657         -    # 2 -> CERT_V3
   658         -    # issuer_id and subject_id for the certificate are left empty
   659         -    # as recommended by gutman's X.509 paper
   660         -    set cert_info [list 2 $opts(serialnumber) $sigalgo $issuer_blob \
   661         -                       $start $end \
   662         -                       [cert_name_to_blob $subject] \
   663         -                       $pubkey {} {} \
   664         -                       $opts(extensions)]
   665         -
   666         -    # We need to get the crypt provider for the issuer cert since
   667         -    # that is what will sign the new cert
   668         -    lassign [cert_property $cissuer key_prov_info] issuer_container issuer_provname issuer_provtype issuer_flags dontcare issuer_keyspec
   669         -    set hissuerprov [crypt_acquire $issuer_container -csp $issuer_provname -csptype $issuer_provtype -keysettype [expr {$issuer_flags & 0x20 ? "machine" : "user"}]]
   670         -    trap {
   671         -        # 0x10001 -> X509_ASN_ENCODING, 2 -> X509_CERT_TO_BE_SIGNED
   672         -        set enc [CryptSignAndEncodeCertificate $hissuerprov $issuer_keyspec \
   673         -                      0x10001 2 $cert_info $sigalgo]
   674         -
   675         -        if {$encoding eq "pem"} {
   676         -            # 0 -> CRYPT_STRING_BASE64HEADER 
   677         -            # 0x80000000 -> LF-only, not CRLF
   678         -            return [CryptBinaryToString $enc 0x80000000]
   679         -        } else {
   680         -            return $enc
   681         -        }
   682         -    } finally {
   683         -        # TBD - test to make sure ok to close this if caller had
   684         -        # it open
   685         -        crypt_free $hissuerprov
   686         -    }
   687         -}
   688         -
   689         -proc twapi::cert_tls_verify {hcert args} {
   690         -
   691         -    parseargs args {
   692         -        {ignoreerrors.arg {}}
   693         -        {cacheendcert.bool 0 0x1}
   694         -        {revocationcheckcacheonly.bool 0 0x80000000}
   695         -        {urlretrievalcacheonly.bool 0 0x4}
   696         -        {disablepass1qualityfiltering.bool 0 0x40}
   697         -        {returnlowerqualitycontexts.bool 0 0x80}
   698         -        {disableauthrootautoupdate.bool 0 0x100}
   699         -        {revocationcheck.arg all {none all leaf excluderoot}}
   700         -        usageall.arg
   701         -        usageany.arg 
   702         -        {engine.arg user {user machine}}
   703         -        {timestamp.arg ""}
   704         -        {hstore.arg NULL}
   705         -        {trustedroots.arg}
   706         -        server.arg
   707         -    } -setvars -maxleftover 0
   708         -
   709         -    set flags [dict! {none 0 all 0x20000000 leaf 0x10000000 excluderoot 0x40000000} $revocationcheck]
   710         -    set flags [tcl::mathop::| $flags $cacheendcert $revocationcheckcacheonly $urlretrievalcacheonly $disablepass1qualityfiltering $returnlowerqualitycontexts $disableauthrootautoupdate]
   711         -
   712         -    set usage_op 1;             # USAGE_MATCH_TYPE_OR
   713         -    if {[info exists usageall]} {
   714         -        if {[info exists usageany]} {
   715         -            error "Only one of -usageall and -usageany may be specified"
   716         -        }
   717         -        set usage_op 0;         # USAGE_MATCH_TYPE_AND
   718         -        set usage [_get_enhkey_usage_oids $usageall]
   719         -    } elseif {[info exists usageany]} {
   720         -        set usage [_get_enhkey_usage_oids $usageany]
   721         -    } else {
   722         -        if {[info exists server]} {
   723         -            set usage [_get_enhkey_usage_oids [list server_auth]]
   724         -        } else {
   725         -            set usage [_get_enhkey_usage_oids [list client_auth]]
   726         -        }
   727         -    }
   728         -
   729         -    set chainh [CertGetCertificateChain \
   730         -                    [dict* {user NULL machine {1 HCERTCHAINENGINE}} $engine] \
   731         -                    $hcert $timestamp $hstore \
   732         -                    [list [list $usage_op $usage]] $flags]
   733         -    
   734         -    trap {
   735         -        set verify_flags 0
   736         -        foreach ignore $ignoreerrors {
   737         -            set verify_flags [expr {$verify_flags | [dict! {
   738         -                time             0x07
   739         -                basicconstraints 0x08
   740         -                unknownca        0x10
   741         -                usage            0x20
   742         -                name             0x40
   743         -                policy           0x80
   744         -                revocation       0xf00
   745         -                criticalextensions 0x2000
   746         -            } $ignore]}]
   747         -        }
   748         -
   749         -        if {[info exists server]} {
   750         -            set role 2;         # AUTHTYPE_SERVER
   751         -        } else {
   752         -            set role 1;         # AUTHTYPE_CLIENT
   753         -            set server ""
   754         -        }
   755         -
   756         -        # I have no clue as to why some of these options have to
   757         -        # be specified in two different places
   758         -        set checks 0
   759         -        foreach {verify check} {
   760         -            0x7 0x2000
   761         -            0xf00 0x80
   762         -            0x10 0x100
   763         -            0x20 0x200
   764         -            0x40 0x1000
   765         -        } {
   766         -            if {$verify_flags & $verify} {
   767         -                set checks [expr {$checks | $check}]
   768         -            }
   769         -        }
   770         -
   771         -        set status [Twapi_CertVerifyChainPolicySSL $chainh [list $verify_flags [list $role $checks $server]]]
   772         -
   773         -        # If caller had provided additional trusted roots that are not
   774         -        # in the Windows trusted store, and the error is that the root is
   775         -        # untrusted, see if the root cert is one of the passed trusted ones
   776         -        if {$status == 0x800B0109 &&
   777         -            [info exists trustedroots] &&
   778         -            [llength $trustedroots]} {
   779         -            set chains [twapi::Twapi_CertChainContexts $chainh]
   780         -            set simple_chains [lindex $chains 1]
   781         -            # We will only deal when there is a single possible chain else
   782         -            # the recheck becomes very complicated as we are not sure if
   783         -            # the recheck will employ the same chain or not.
   784         -            if {[llength $simple_chains] == 1} {
   785         -                set certs_in_chain [lindex $simple_chains 0 1]
   786         -                # Get thumbprint of root cert
   787         -                set thumbprint [cert_thumbprint [lindex $certs_in_chain end 0]]
   788         -                # Match against each trusted root
   789         -                set trusted 0
   790         -                foreach trusted_cert $trustedroots {
   791         -                    if {$thumbprint eq [cert_thumbprint $trusted_cert]} {
   792         -                        set trusted 1
   793         -                        break
   794         -                    }
   795         -                }
   796         -                if {$trusted} {
   797         -                    # Yes, the root is trusted. It is not enough to
   798         -                    # say validation is ok because even if root
   799         -                    # is trusted, other errors might show up
   800         -                    # once untrusted roots are ignored. So we have
   801         -                    # to call the verification again.
   802         -                    # 0x10 -> CERT_CHAIN_POLICY_ALLOW_UNKNOWN_CA_FLAG
   803         -                    set verify_flags [expr {$verify_flags | 0x10}]
   804         -                    # 0x100 -> SECURITY_FLAG_IGNORE_UNKNOWN_CA
   805         -                    set checks [expr {$checks | 0x100}]
   806         -                    # Retry the call ignoring root errors
   807         -                    set status [Twapi_CertVerifyChainPolicySSL $chainh [list $verify_flags [list $role $checks $server]]]
   808         -                }
   809         -            }
   810         -        }
   811         -
   812         -        return [dict*  {
   813         -            0x00000000 ok
   814         -            0x80096004 signature
   815         -            0x80092010 revoked
   816         -            0x800b0109 untrustedroot
   817         -            0x800b010d untrustedtestroot
   818         -            0x800b010a chaining
   819         -            0x800b0110 wrongusage
   820         -            0x800b0101 expired
   821         -            0x800b0114 name
   822         -            0x800b0113 policy
   823         -            0x80096019 basicconstraints
   824         -            0x800b0105 criticalextension
   825         -            0x800b0102 validityperiodnesting
   826         -            0x80092012 norevocationcheck
   827         -            0x80092013 revocationoffline
   828         -            0x800b010f cnmatch
   829         -            0x800b0106 purpose
   830         -            0x800b0103 carole
   831         -        } [hex32 $status]]
   832         -    } finally {
   833         -        if {[info exists certs_in_chain]} {
   834         -            foreach cert_stat $certs_in_chain {
   835         -                cert_release [lindex $cert_stat 0]
   836         -            }
   837         -        }
   838         -        CertFreeCertificateChain $chainh
   839         -    }
   840         -
   841         -    return $status
   842         -}
   843         -
   844         -proc twapi::cert_locate_private_key {hcert args} {
   845         -    parseargs args {
   846         -        {keysettype.arg any {any user machine}}
   847         -        {silent 0 0x40}
   848         -    } -maxleftover 0 -setvars
   849         -    
   850         -    return [CryptFindCertificateKeyProvInfo $hcert \
   851         -                [expr {$silent | [dict get {any 0 user 1 machine 2} $keysettype]}]]
   852         -}
   853         -
   854         -proc twapi::cert_request_parse {req args} {
   855         -    parseargs args {
   856         -        {encoding.arg der {der pem}}
   857         -    } -setvars -maxleftover 0
   858         -
   859         -    if {$encoding eq "pem"} {
   860         -        # 3 -> CRYPT_STRING_BASE64REQUESTHEADER 
   861         -        set req [CryptStringToBinary $req 3]
   862         -    }
   863         -
   864         -    # 4 -> X509_CERT_REQUEST_TO_BE_SIGNED 
   865         -    lassign [::twapi::CryptDecodeObjectEx 4 $req] ver subject pubkey attrs
   866         -    lappend reqdict version $ver pubkey $pubkey attributes $attrs
   867         -    lappend reqdict subject [cert_blob_to_name $subject]
   868         -    foreach attr $attrs {
   869         -        lassign $attr oid values
   870         -        if {$oid eq "1.2.840.113549.1.9.14"} {
   871         -            # Extensions
   872         -            set extensions {}
   873         -            foreach ext [lindex $values 0] {
   874         -                lassign $ext oid critical value
   875         -                set value [_cert_decode_extension $oid $value]
   876         -                switch -exact -- $oid {
   877         -                    2.5.29.15 { set oidname -keyusage }
   878         -                    2.5.29.17 { set oidname -altnames }
   879         -                    2.5.29.19 { set oidname -basicconstraints }
   880         -                    2.5.29.37 { set oidname -enhkeyusage }
   881         -                    default { set oidname $oid }
   882         -                }
   883         -                lappend extensions $oidname [list $value $critical]
   884         -            }
   885         -            lappend reqdict extensions $extensions
   886         -        }
   887         -    }
   888         -
   889         -    return $reqdict
   890         -}
   891         -
   892         -
   893         -proc twapi::cert_request_create {subject hprov keyspec args} {
   894         -    set args [_cert_create_parse_options $args opts]
   895         -    # TBD - barf if any elements other than extensions is set
   896         -    # TBD - document signaturealgorithmid
   897         -    parseargs args {
   898         -        {signaturealgorithmid.arg oid_rsa_sha1rsa}
   899         -        {encoding.arg der {der pem}}
   900         -    } -setvars -maxleftover 0
   901         -    
   902         -    set sigoid [oid $signaturealgorithmid]
   903         -    if {$sigoid ni [list [oid oid_rsa_sha1rsa] [oid oid_rsa_md5rsa] [oid oid_x957_sha1dsa]]} {
   904         -        badargs! "Invalid signature algorithm '$sigalg'"
   905         -    }
   906         -    set keyspec [twapi::_crypt_keyspec $keyspec]
   907         -    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
   908         -    # Pass oid_rsa_rsa as that seems to be what OPENSSL understands in
   909         -    # a CSR
   910         -    set pubkeyinfo [crypt_public_key $hprov $keyspec oid_rsa_rsa]
   911         -    set attrs [list 0 [cert_name_to_blob $subject] $pubkeyinfo]
   912         -    if {[llength $opts(extensions)]} {
   913         -        lappend attrs [list [list [oid oid_rsa_certextensions] [list $opts(extensions)]]]
   914         -    } else {
   915         -        lappend attrs {}
   916         -    }
   917         -    set req [CryptSignAndEncodeCertificate $hprov $keyspec 0x10001 4 $attrs $sigoid]
   918         -    if {$encoding eq "pem"} {
   919         -        # 3 -> CRYPT_STRING_BASE64REQUESTHEADER 
   920         -        # 0x80000000 -> LF-only, not CRLF
   921         -        return [CryptBinaryToString $req 0x80000003]
   922         -    } else {
   923         -        return $req
   924         -    }
   925         -}
   926         -
   927         -
   928         -################################################################
   929         -# Cryptographic context commands
   930         -
   931         -proc twapi::crypt_acquire {keycontainer args} {
   932         -    parseargs args {
   933         -        csp.arg
   934         -        {csptype.arg prov_rsa_full}
   935         -        {keysettype.arg user {user machine}}
   936         -        {create.bool 0 0x8}
   937         -        {silent.bool 0 0x40}
   938         -        {verifycontext.bool 0 0xf0000000}
   939         -    } -maxleftover 0 -nulldefault -setvars
   940         -    
   941         -    # Based on http://support.microsoft.com/kb/238187, if verifycontext
   942         -    # is not specified, default container must not be used as keys
   943         -    # from different applications might overwrite. The docs for
   944         -    # CryptAcquireContext say keycontainer must be empty if verifycontext
   945         -    # is specified. Thus they are mutually exclusive.
   946         -    if {! $verifycontext} {
   947         -        if {$keycontainer eq ""} {
   948         -            badargs! "Option -verifycontext must be specified for the default key container."
   949         -        }
   950         -    }
   951         -
   952         -    set flags [expr {$create | $silent | $verifycontext}]
   953         -    if {$keysettype eq "machine"} {
   954         -        incr flags 0x20;        # CRYPT_KEYSET_MACHINE
   955         -    }
   956         -
   957         -    return [CryptAcquireContext $keycontainer $csp [_csp_type_name_to_id $csptype] $flags]
   958         -}
   959         -
   960         -proc twapi::crypt_free {hcrypt} {
   961         -    twapi::CryptReleaseContext $hcrypt
   962         -}
   963         -
   964         -proc twapi::crypt_key_container_delete {keycontainer args} {
   965         -    parseargs args {
   966         -        csp.arg
   967         -        {csptype.arg prov_rsa_full}
   968         -        {keysettype.arg user {machine user}}
   969         -        force
   970         -    } -maxleftover 0 -nulldefault -setvars
   971         -
   972         -    if {$keycontainer eq "" && ! $force} {
   973         -        error "Default container cannot be deleted unless the -force option is specified"
   974         -    }
   975         -
   976         -    set flags 0x10;             # CRYPT_DELETEKEYSET
   977         -    if {$keysettype eq "machine"} {
   978         -        incr flags 0x20;        # CRYPT_MACHINE_KEYSET
   979         -    }
   980         -
   981         -    return [CryptAcquireContext $keycontainer $csp [_csp_type_name_to_id $csptype] $flags]
   982         -}
   983         -
   984         -proc twapi::crypt_key_generate {hprov algid args} {
   985         -
   986         -    array set opts [parseargs args {
   987         -        {archivable.bool 0 0x4000}
   988         -        {salt.bool 0 4}
   989         -        {exportable.bool 0 1}
   990         -        {pregen.bool 0x40}
   991         -        {userprotected.bool 0 2}
   992         -        {nosalt40.bool 0 0x10}
   993         -        {size.int 0}
   994         -    } -maxleftover 0]
   995         -
   996         -    if {![string is integer -strict $algid]} {
   997         -        # See wincrypt.h in SDK
   998         -        switch -nocase -exact -- $algid {
   999         -            keyexchange {set algid 1}
  1000         -            signature {set algid 2}
  1001         -            default {
  1002         -                set id [CertOIDToAlgId [oid $algid]]
  1003         -                if {$id == 0} {
  1004         -                    badargs! "Invalid algorithm id '$algid'"
  1005         -                }
  1006         -                set algid $id