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 Unified 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
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
#----------------------------------------------------------------------------
#   Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com)
#----------------------------------------------------------------------------
#
#   $Id$
#
#
#   The higher level functions of tDOM written in plain Tcl.
#
#
#   The contents of this file are subject to the Mozilla Public License
#   Version 1.1 (the "License"); you may not use this file except in
#   compliance with the License. You may obtain a copy of the License at
#   http://www.mozilla.org/MPL/
#
#   Software distributed under the License is distributed on an "AS IS"
#   basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
#   License for the specific language governing rights and limitations
#   under the License.
#
#   The Original Code is tDOM.
#
#   The Initial Developer of the Original Code is Jochen Loewer
#   Portions created by Jochen Loewer are Copyright (C) 1998, 1999
#   Jochen Loewer. All Rights Reserved.
#
#   Contributor(s):
#       Rolf Ade (rolf@pointsman.de):   'fake' nodelists/live childNodes
#
#   written by Jochen Loewer
#   April, 1999
#
#----------------------------------------------------------------------------

package require tdom 

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

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

    namespace export xmlOpenFile xmlReadFile extRefHandler baseURL
}

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

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

}

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

    error "Sorry, load method not implemented yet!"

}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    upvar $output_var output

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

    foreach {match action} $trans_specs {

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

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

    return $node
}

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

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

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

    return [llength [$nodeListNode childNodes]]
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    set fd [open $filename]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

# EOF
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/tdom/tdom083.dll.

cannot compute difference between binary files

Deleted winlibs/twapi/LICENSE.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Copyright (c) 2003-2012, Ashok P. Nadkarni
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

- Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.  

- Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.

- The name of the copyright holder and any other contributors may not
be used to endorse or promote products derived from this software
without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


























































Deleted winlibs/twapi/README.TXT.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
# Tcl Windows API (TWAPI) 4.1

This is the release version of TWAPI 4.1.

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

## Supported platforms

TWAPI 4.1 requires

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

## Changes since 4.0

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

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

## Distributions

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

## TWAPI Summary

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

Functions in the following areas are implemented:

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












































































































































Deleted winlibs/twapi/accounts.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
#
# Copyright (c) 2009-2015, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

package require twapi_security

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

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

    record NetEnumResult {moredata hresume totalentries entries}

}

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

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

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


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


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

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

    NetUserDel $opts(system) $username
}


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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

    return [array get result]
}

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

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

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

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

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


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

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

    # TBD - rewrite this to be atomic

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

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

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

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

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

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

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

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

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

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

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

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

    return $result
}

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

    NetGroupDel $opts(system) $grpname
}

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

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

    NetLocalGroupDel $opts(system) $grpname
}


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

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

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

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

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

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

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

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


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

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


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

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

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

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


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

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

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

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


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

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

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

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

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

}

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

            lappend result $luid

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

    return $result
}


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

    array set session [LsaGetLogonSessionData $luid]

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

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

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

    return [array get result]
}




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

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

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

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

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

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

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

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

proc twapi::_set_user_priv_level {username priv_level args} {

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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




















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/adsi.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
#
# Copyright (c) 2010-2012, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# ADSI routines

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

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
























































Deleted winlibs/twapi/apputil.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
#
# Copyright (c) 2003-2012, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

namespace eval twapi {}

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

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

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

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

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

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

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

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

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

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

    return [GetPrivateProfileSectionNames $opts(inifile)]
}

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

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


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

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

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



<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




































































































































































































































Deleted winlibs/twapi/base.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
#
# Copyright (c) 2012-2014, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# Commands in twapi_base module

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

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

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

}



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

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

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

    # Same version, ok
    return 1
}

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

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

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

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

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

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

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

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

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

    set flags 0

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

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

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

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

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

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

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

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

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

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

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

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

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

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

proc twapi::_init_security_defs {} {
    variable security_defs

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

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

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

        SYSTEM_MANDATORY_LABEL_NO_WRITE_UP         0x1
        SYSTEM_MANDATORY_LABEL_NO_READ_UP          0x2
        SYSTEM_MANDATORY_LABEL_NO_EXECUTE_UP       0x4

        ACL_REVISION     2
        ACL_REVISION_DS  4

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

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

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

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

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

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

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

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

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

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

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

        EVENT_MODIFY_STATE             0x00000002
        EVENT_ALL_ACCESS               0x001F0003

        SEMAPHORE_MODIFY_STATE         0x00000002
        SEMAPHORE_ALL_ACCESS           0x001F0003

        MUTANT_QUERY_STATE             0x00000001
        MUTANT_ALL_ACCESS              0x001F0001

        MUTEX_MODIFY_STATE             0x00000001
        MUTEX_ALL_ACCESS               0x001F0001

        TIMER_QUERY_STATE              0x00000001
        TIMER_MODIFY_STATE             0x00000002
        TIMER_ALL_ACCESS               0x001F0003

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

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

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

        COM_RIGHTS_EXECUTE 1
        COM_RIGHTS_EXECUTE_LOCAL 2
        COM_RIGHTS_EXECUTE_REMOTE 4
        COM_RIGHTS_ACTIVATE_LOCAL 8
        COM_RIGHTS_ACTIVATE_REMOTE 16
    }

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

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

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

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


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

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

        set rights [list ]

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

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

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

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

        #
        # OK, now map individual bits

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

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

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

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

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

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

        return $rights
    }

    return [_access_mask_to_rights $access_mask $type]
}

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

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

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

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

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

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

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

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

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

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

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

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

    return $result
}


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

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

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

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

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


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

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

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

    return $result
}

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

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

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


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

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

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

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

    set user [GetUserNameEx $format]

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

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

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

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

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

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

# Eventlog stuff in the base package

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

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

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

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

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

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

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

    unset eventlog_handles($hevl)
}


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

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


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

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


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

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

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

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

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

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

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

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

    incr flags $opts(type)

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

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

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

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

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

    incr flags $opts(type)

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

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

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

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

### Common disk related

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

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

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

namespace eval twapi::recordarray {}

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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

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

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

    upvar 1 $arrayvarname var

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

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

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

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

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

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

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

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

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

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

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

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




















































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/clipboard.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
#
# Copyright (c) 2004, 2008 Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# Clipboard related commands

namespace eval twapi {
}

# Open the clipboard
# TBD - why no mechanism to pass window handle to OpenClipboard?
proc twapi::open_clipboard {} {
    OpenClipboard 0
}

# Close the clipboard
proc twapi::close_clipboard {} {
    catch {CloseClipboard}
    return
}

# Empty the clipboard
proc twapi::empty_clipboard {} {
    EmptyClipboard
}

# Read data from the clipboard
proc twapi::read_clipboard {fmt} {
    # Always catch errors and close clipboard before passing exception on
    # Also ensure memory unlocked
    trap {
        set h [GetClipboardData $fmt]
        set p [GlobalLock $h]
        set data [Twapi_ReadMemory 1 $p 0 [GlobalSize $h]]
    } onerror {} {
        catch {close_clipboard}
        rethrow
    } finally {
        # If p exists, then we must have locked the handle
        if {[info exists p]} {
            GlobalUnlock $h
        }
    }
    return $data
}

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

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

    return $data
}

# Write data to the clipboard
proc twapi::write_clipboard {fmt data} {
    # Always catch errors and close
    # clipboard before passing exception on
    trap {
        # For byte arrays, string length does return correct size
        # (DO NOT USE string bytelength - see Tcl docs!)
        set len [string length $data]

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

        Twapi_WriteMemory 1 $mem_p 0 $len $data

        # The rest of this code just to ensure we do not free
        # memory beyond this point irrespective of error/success
        set h $mem_h
        unset mem_p mem_h
        GlobalUnlock $h
        SetClipboardData $fmt $h
    } onerror {} {
        catch {close_clipboard}
        rethrow
    } finally {
        if {[info exists mem_p]} {
            GlobalUnlock $mem_h
        }
        if {[info exists mem_h]} {
            GlobalFree $mem_h
        }
    }
    return
}

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

    # Always catch errors and close
    # clipboard before passing exception on
    trap {
        # Convert \n to \r\n leaving existing \r\n alone
        if {! $opts(raw)} {
            set data [regsub -all {(^|[^\r])\n} $data[set data ""] \\1\r\n]
        }
                  
        set mem_size [expr {2*(1+[string length $data])}]

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

        # 3 -> write memory as Unicode
        Twapi_WriteMemory 3 $mem_p 0 $mem_size $data

        # The rest of this code just to ensure we do not free
        # memory beyond this point irrespective of error/success
        set h $mem_h
        unset mem_h mem_p
        GlobalUnlock $h
        SetClipboardData 13 $h;         # 13 -> Unicode format
    } onerror {} {
        catch {close_clipboard}
        rethrow
    } finally {
        if {[info exists mem_p]} {
            GlobalUnlock $mem_h
        }
        if {[info exists mem_h]} {
            GlobalFree $mem_h
        }
    }
    return
}

# Get current clipboard formats
proc twapi::get_clipboard_formats {} {
    return [Twapi_EnumClipboardFormats]
}

# Get registered clipboard format name. Clipboard does not have to be open
proc twapi::get_registered_clipboard_format_name {fmt} {
    return [GetClipboardFormatName $fmt]
}

# Register a clipboard format
proc twapi::register_clipboard_format {fmt_name} {
    RegisterClipboardFormat $fmt_name
}

# Returns 1/0 depending on whether a format is on the clipboard. Clipboard
# does not have to be open
proc twapi::clipboard_format_available {fmt} {
    return [IsClipboardFormatAvailable $fmt]
}



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

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

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

proc twapi::start_clipboard_monitor {script} {
    variable _clipboard_monitors

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

    lappend _clipboard_monitors $id $script
    return $id
}



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

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

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

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












































































































































































































































































































































































































































































Deleted winlibs/twapi/com.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
2064
2065
2066
2067
2068
2069
2070
2071
2072
2073
2074
2075
2076
2077
2078
2079
2080
2081
2082
2083
2084
2085
2086
2087
2088
2089
2090
2091
2092
2093
2094
2095
2096
2097
2098
2099
2100
2101
2102
2103
2104
2105
2106
2107
2108
2109
2110
2111
2112
2113
2114
2115
2116
2117
2118
2119
2120
2121
2122
2123
2124
2125
2126
2127
2128
2129
2130
2131
2132
2133
2134
2135
2136
2137
2138
2139
2140
2141
2142
2143
2144
2145
2146
2147
2148
2149
2150
2151
2152
2153
2154
2155
2156
2157
2158
2159
2160
2161
2162
2163
2164
2165
2166
2167
2168
2169
2170
2171
2172
2173
2174
2175
2176
2177
2178
2179
2180
2181
2182
2183
2184
2185
2186
2187
2188
2189
2190
2191
2192
2193
2194
2195
2196
2197
2198
2199
2200
2201
2202
2203
2204
2205
2206
2207
2208
2209
2210
2211
2212
2213
2214
2215
2216
2217
2218
2219
2220
2221
2222
2223
2224
2225
2226
2227
2228
2229
2230
2231
2232
2233
2234
2235
2236
2237
2238
2239
2240
2241
2242
2243
2244
2245
2246
2247
2248
2249
2250
2251
2252
2253
2254
2255
2256
2257
2258
2259
2260
2261
2262
2263
2264
2265
2266
2267
2268
2269
2270
2271
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283
2284
2285
2286
2287
2288
2289
2290
2291
2292
2293
2294
2295
2296
2297
2298
2299
2300
2301
2302
2303
2304
2305
2306
2307
2308
2309
2310
2311
2312
2313
2314
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325
2326
2327
2328
2329
2330
2331
2332
2333
2334
2335
2336
2337
2338
2339
2340
2341
2342
2343
2344
2345
2346
2347
2348
2349
2350
2351
2352
2353
2354
2355
2356
2357
2358
2359
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
2378
2379
2380
2381
2382
2383
2384
2385
2386
2387
2388
2389
2390
2391
2392
2393
2394
2395
2396
2397
2398
2399
2400
2401
2402
2403
2404
2405
2406
2407
2408
2409
2410
2411
2412
2413
2414
2415
2416
2417
2418
2419
2420
2421
2422
2423
2424
2425
2426
2427
2428
2429
2430
2431
2432
2433
2434
2435
2436
2437
2438
2439
2440
2441
2442
2443
2444
2445
2446
2447
2448
2449
2450
2451
2452
2453
2454
2455
2456
2457
2458
2459
2460
2461
2462
2463
2464
2465
2466
2467
2468
2469
2470
2471
2472
2473
2474
2475
2476
2477
2478
2479
2480
2481
2482
2483
2484
2485
2486
2487
2488
2489
2490
2491
2492
2493
2494
2495
2496
2497
2498
2499
2500
2501
2502
2503
2504
2505
2506
2507
2508
2509
2510
2511
2512
2513
2514
2515
2516
2517
2518
2519
2520
2521
2522
2523
2524
2525
2526
2527
2528
2529
2530
2531
2532
2533
2534
2535
2536
2537
2538
2539
2540
2541
2542
2543
2544
2545
2546
2547
2548
2549
2550
2551
2552
2553
2554
2555
2556
2557
2558
2559
2560
2561
2562
2563
2564
2565
2566
2567
2568
2569
2570
2571
2572
2573
2574
2575
2576
2577
2578
2579
2580
2581
2582
2583
2584
2585
2586
2587
2588
2589
2590
2591
2592
2593
2594
2595
2596
2597
2598
2599
2600
2601
2602
2603
2604
2605
2606
2607
2608
2609
2610
2611
2612
2613
2614
2615
2616
2617
2618
2619
2620
2621
2622
2623
2624
2625
2626
2627
2628
2629
2630
2631
2632
2633
2634
2635
2636
2637
2638
2639
2640
2641
2642
2643
2644
2645
2646
2647
2648
2649
2650
2651
2652
2653
2654
2655
2656
2657
2658
2659
2660
2661
2662
2663
2664
2665
2666
2667
2668
2669
2670
2671
2672
2673
2674
2675
2676
2677
2678
2679
2680
2681
2682
2683
2684
2685
2686
2687
2688
2689
2690
2691
2692
2693
2694
2695
2696
2697
2698
2699
2700
2701
2702
2703
2704
2705
2706
2707
2708
2709
2710
2711
2712
2713
2714
2715
2716
2717
2718
2719
2720
2721
2722
2723
2724
2725
2726
2727
2728
2729
2730
2731
2732
2733
2734
2735
2736
2737
2738
2739
2740
2741
2742
2743
2744
2745
2746
2747
2748
2749
2750
2751
2752
2753
2754
2755
2756
2757
2758
2759
2760
2761
2762
2763
2764
2765
2766
2767
2768
2769
2770
2771
2772
2773
2774
2775
2776
2777
2778
2779
2780
2781
2782
2783
2784
2785
2786
2787
2788
2789
2790
2791
2792
2793
2794
2795
2796
2797
2798
2799
2800
2801
2802
2803
2804
2805
2806
2807
2808
2809
2810
2811
2812
2813
2814
2815
2816
2817
2818
2819
2820
2821
2822
2823
2824
2825
2826
2827
2828
2829
2830
2831
2832
2833
2834
2835
2836
2837
2838
2839
2840
2841
2842
2843
2844
2845
2846
2847
2848
2849
2850
2851
2852
2853
2854
2855
2856
2857
2858
2859
2860
2861
2862
2863
2864
2865
2866
2867
2868
2869
2870
2871
2872
2873
2874
2875
2876
2877
2878
2879
2880
2881
2882
2883
2884
2885
2886
2887
2888
2889
2890
2891
2892
2893
2894
2895
2896
2897
2898
2899
2900
2901
2902
2903
2904
2905
2906
2907
2908
2909
2910
2911
2912
2913
2914
2915
2916
2917
2918
2919
2920
2921
2922
2923
2924
2925
2926
2927
2928
2929
2930
2931
2932
2933
2934
2935
2936
2937
2938
2939
2940
2941
2942
2943
2944
2945
2946
2947
2948
2949
2950
2951
2952
2953
2954
2955
2956
2957
2958
2959
2960
2961
2962
2963
2964
2965
2966
2967
2968
2969
2970
2971
2972
2973
2974
2975
2976
2977
2978
2979
2980
2981
2982
2983
2984
2985
2986
2987
2988
2989
2990
2991
2992
2993
2994
2995
2996
2997
2998
2999
3000
3001
3002
3003
3004
3005
3006
3007
3008
3009
3010
3011
3012
3013
3014
3015
3016
3017
3018
3019
3020
3021
3022
3023
3024
3025
3026
3027
3028
3029
3030
3031
3032
3033
3034
3035
3036
3037
3038
3039
3040
3041
3042
3043
3044
3045
3046
3047
3048
3049
3050
3051
3052
3053
3054
3055
3056
3057
3058
3059
3060
3061
3062
3063
3064
3065
3066
3067
3068
3069
3070
3071
3072
3073
3074
3075
3076
3077
3078
3079
3080
3081
3082
3083
3084
3085
3086
3087
3088
3089
3090
3091
3092
3093
3094
3095
3096
3097
3098
3099
3100
3101
3102
3103
3104
3105
3106
3107
3108
3109
3110
3111
3112
3113
3114
3115
3116
3117
3118
3119
3120
3121
3122
3123
3124
3125
3126
3127
3128
3129
3130
3131
3132
3133
3134
3135
3136
3137
3138
3139
3140
3141
3142
3143
3144
3145
3146
3147
3148
3149
3150
3151
3152
3153
3154
3155
3156
3157
3158
3159
3160
3161
3162
3163
3164
3165
3166
3167
3168
3169
3170
3171
3172
3173
3174
3175
3176
3177
3178
3179
3180
3181
3182
3183
3184
3185
3186
3187
3188
3189
3190
3191
3192
3193
3194
3195
3196
3197
3198
3199
3200
3201
3202
3203
3204
3205
3206
3207
3208
3209
3210
3211
3212
3213
3214
3215
3216
3217
3218
3219
3220
3221
3222
3223
3224
3225
3226
3227
3228
3229
3230
3231
3232
3233
3234
3235
3236
3237
3238
3239
3240
3241
3242
3243
3244
3245
3246
3247
3248
3249
3250
3251
3252
3253
3254
3255
3256
3257
3258
3259
3260
3261
3262
3263
3264
3265
3266
3267
3268
3269
3270
3271
3272
3273
3274
3275
3276
3277
3278
3279
3280
3281
3282
3283
3284
3285
3286
3287
3288
3289
3290
3291
3292
3293
3294
3295
3296
3297
3298
3299
3300
3301
3302
3303
3304
3305
3306
3307
3308
3309
3310
3311
3312
3313
3314
3315
3316
3317
3318
3319
3320
3321
3322
3323
3324
3325
3326
3327
3328
3329
3330
3331
3332
3333
3334
3335
3336
3337
3338
3339
3340
3341
3342
3343
3344
3345
3346
3347
3348
3349
3350
3351
3352
3353
3354
3355
3356
3357
3358
3359
3360
3361
3362
3363
3364
3365
3366
3367
3368
3369
3370
3371
3372
3373
3374
3375
3376
3377
3378
3379
3380
3381
3382
3383
3384
3385
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396
3397
3398
3399
3400
3401
3402
3403
3404
3405
3406
3407
3408
3409
3410
3411
3412
3413
3414
3415
3416
3417
3418
3419
3420
3421
3422
3423
3424
3425
3426
3427
3428
3429
3430
3431
3432
3433
3434
3435
3436
3437
3438
3439
3440
3441
3442
3443
3444
3445
3446
3447
3448
3449
3450
3451
3452
3453
3454
3455
3456
3457
3458
3459
3460
3461
3462
3463
3464
3465
3466
3467
3468
3469
3470
3471
3472
3473
3474
3475
3476
3477
3478
3479
3480
3481
3482
3483
3484
3485
3486
3487
3488
3489
3490
3491
3492
3493
3494
3495
3496
3497
3498
3499
3500
3501
3502
3503
3504
3505
3506
3507
3508
3509
3510
3511
3512
3513
3514
3515
3516
3517
3518
3519
3520
3521
3522
3523
3524
3525
3526
3527
3528
3529
3530
3531
3532
3533
3534
3535
3536
3537
3538
3539
3540
3541
3542
3543
3544
3545
3546
3547
3548
3549
3550
3551
3552
3553
3554
3555
3556
3557
3558
3559
3560
3561
3562
3563
3564
3565
3566
3567
3568
3569
3570
3571
3572
3573
3574
3575
3576
3577
3578
3579
3580
3581
3582
3583
3584
3585
3586
3587
3588
3589
3590
3591
3592
3593
3594
3595
3596
3597
3598
3599
3600
3601
3602
3603
3604
3605
3606
3607
3608
3609
3610
3611
3612
3613
3614
3615
3616
3617
3618
3619
3620
3621
3622
3623
3624
3625
3626
3627
3628
3629
3630
3631
3632
3633
3634
3635
3636
3637
3638
3639
3640
3641
3642
3643
3644
3645
3646
3647
3648
3649
3650
3651
3652
3653
3654
3655
3656
3657
3658
3659
3660
3661
3662
3663
3664
3665
3666
3667
3668
3669
3670
3671
3672
3673
3674
3675
3676
3677
3678
3679
3680
3681
3682
3683
3684
3685
3686
3687
3688
3689
3690
3691
3692
3693
3694
3695
3696
3697
3698
3699
3700
3701
3702
3703
3704
3705
3706
3707
3708
3709
3710
3711
3712
3713
3714
3715
3716
3717
3718
3719
3720
3721
3722
3723
3724
3725
3726
3727
3728
3729
3730
3731
3732
3733
3734
3735
3736
3737
3738
3739
3740
3741
3742
3743
3744
3745
3746
3747
3748
3749
3750
3751
3752
3753
3754
3755
3756
3757
3758
3759
3760
3761
3762
3763
3764
3765
3766
3767
3768
3769
3770
3771
3772
3773
3774
3775
3776
3777
3778
3779
3780
3781
3782
3783
3784
3785
3786
3787
3788
3789
3790
3791
3792
3793
3794
3795
3796
3797
3798
3799
3800
3801
3802
3803
3804
3805
3806
3807
3808
3809
3810
3811
3812
3813
3814
3815
3816
3817
3818
3819
3820
3821
3822
3823
3824
3825
3826
3827
3828
3829
3830
3831
3832
3833
3834
3835
3836
3837
3838
3839
3840
3841
3842
3843
3844
3845
3846
3847
3848
3849
3850
3851
3852
3853
3854
3855
3856
3857
3858
3859
3860
3861
3862
3863
3864
3865
3866
3867
3868
3869
3870
3871
3872
3873
3874
3875
3876
3877
3878
3879
3880
3881
3882
3883
3884
3885
3886
3887
3888
3889
3890
3891
3892
3893
3894
3895
3896
3897
3898
3899
3900
3901
3902
3903
3904
3905
3906
3907
3908
3909
3910
3911
3912
3913
3914
3915
3916
3917
3918
3919
3920
3921
3922
3923
3924
3925
3926
3927
3928
3929
3930
3931
3932
3933
3934
3935
3936
3937
3938
3939
3940
3941
3942
3943
3944
3945
3946
3947
3948
3949
3950
3951
3952
3953
3954
3955
3956
3957
3958
3959
3960
3961
3962
3963
3964
3965
3966
3967
3968
3969
3970
3971
3972
3973
3974
3975
3976
3977
3978
3979
3980
3981
3982
3983
3984
3985
3986
3987
3988
3989
3990
3991
3992
3993
3994
3995
3996
3997
3998
3999
4000
4001
4002
4003
4004
4005
4006
4007
4008
4009
4010
4011
4012
4013
4014
4015
4016
4017
4018
4019
4020
4021
4022
4023
4024
4025
4026
4027
4028
4029
4030
4031
4032
4033
4034
4035
4036
4037
4038
4039
4040
4041
4042
4043
4044
4045
4046
4047
4048
4049
4050
4051
#
# Copyright (c) 2006-2014 Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    # CLSCTX_NO_CUSTOM_MARSHAL ?
    set flags $opts(nocustommarshal)

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

    setbits flags $model

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

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

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

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

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

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

    lassign [_resolve_iid $opts(interface)] iid iid_name

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

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

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

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

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

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

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


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

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

    return [Automation new $proxyobj $lcid]
}

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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


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

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

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


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

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

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

    return
}

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

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

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




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

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

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

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

    return
}

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

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

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

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

    return $names_already_done
}



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

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

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

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

    return $typedesc
}


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

    return $typedesc
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

}

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

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

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

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

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

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


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

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


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

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

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

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

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

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

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

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

    return [list $paramflags $paramtype $paramname]
}

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

    set guid [canonicalize_guid $guid]

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

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

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

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


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

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

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

        set _ifc $ifc

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

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

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

    method DebugRefCounts {} {
        my variable _nrefs

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

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

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

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

    twapi_exportall
}

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

        my variable _ifc
        set _ifc $ifc

        my variable _clsid
        set _clsid $objclsid

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

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

        set _nrefs 1
    }

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

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

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

    method DebugRefCounts {} {
        my variable _nrefs
        my variable _ifc

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

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

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

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

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

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

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

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

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

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

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

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

    twapi_exportall
}

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

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

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

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

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


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

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

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

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

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

        return $_guid
    }

    method @GetCoClassTypeInfo {} {
        my variable _ifc

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

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

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

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

    twapi_exportall
}


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    twapi_exportall
}


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

        return $result
    }

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

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

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


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

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

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

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

        return $result
    }

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

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

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

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

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

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

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

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

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

        return $result
    }

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

        lassign [my GetDocumentation $memid] name docstring helpctx helpfile

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

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

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

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

    twapi_exportall
}


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

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

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

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

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

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

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

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

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

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

        return $result
    }

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

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

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

        lassign $args varname script
        upvar $varname varti

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

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

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

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

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

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

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

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

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

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

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

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

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

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


        return $code
    }

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

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

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

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


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

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

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

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

    twapi_exportall
}

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

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

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

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

    twapi_exportall
}

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

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

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

    twapi_exportall
}

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

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

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

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

    destructor {
        my variable _proxy  _sinks

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    method -destroy {} {
        my destroy
    }

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

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

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

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

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

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

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

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

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

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

    method -iterate {args} {
        my variable _lcid

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    twapi_exportall
}

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

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

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

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


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

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

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

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

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

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


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

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

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

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

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

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

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

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

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

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

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

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

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

proc twapi::suspend_factories {} {
    CoSuspendClassObjects
}

proc twapi::resume_factories {} {
    CoResumeClassObjects
}

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

    set script_path [file normalize $script_path]

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

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

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

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

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

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

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

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

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

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

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

    return
}

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

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

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

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

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

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

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

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

    return
}


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/console.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
#
# Copyright (c) 2004-2014, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

namespace eval twapi {
}

# Allocate a new console
proc twapi::allocate_console {} {
    AllocConsole
}

# Free a console
proc twapi::free_console {} {
    FreeConsole
}

# Get a console handle
proc twapi::get_console_handle {type} {
    switch -exact -- $type {
        0 -
        stdin { set fn "CONIN\$" }
        1 -
        stdout -
        2 -
        stderr { set fn "CONOUT\$" }
        default {
            error "Unknown console handle type '$type'"
        }
    }

    # 0xC0000000 -> GENERIC_READ | GENERIC_WRITE
    # 3 -> FILE_SHARE_READ | FILE_SHARE_WRITE
    # 3 -> OPEN_EXISTING
    return [CreateFile $fn \
                0xC0000000 \
                3 \
                {{} 1} \
                3 \
                0 \
                NULL]
}

# Get a console handle
proc twapi::get_standard_handle {type} {
    switch -exact -- $type {
        0 -
        -11 -
        stdin { set type -11 }
        1 -
        -12 -
        stdout { set type -12 }
        2 -
        -13 -
        stderr { set type -13 }
        default {
            error "Unknown console handle type '$type'"
        }
    }
    return [GetStdHandle $type]
}

# Set a console handle
proc twapi::set_standard_handle {type handle} {
    switch -exact -- $type {
        0 -
        -11 -
        stdin { set type -11 }
        1 -
        -12 -
        stdout { set type -12 }
        2 -
        -13 -
        stderr { set type -13 }
        default {
            error "Unknown console handle type '$type'"
        }
    }
    return [SetStdHandle $type $handle]
}

proc twapi::_console_output_attr_to_flags {attrs} {
    set flags 0
    foreach {attr bool} $attrs {
        if {$bool} {
            set flags [expr {$flags | [_console_output_attr $attr]}]
        }
    }
    return $flags
}

proc twapi::_flags_to_console_output_attr {flags} {
    # Check for multiple bit attributes first, in order
    set attrs {}
    foreach attr {
        -fgwhite -bgwhite -fggray -bggray
        -fgturquoise -bgturquoise -fgpurple -bgpurple -fgyellow -bgyellow
        -fgred -bgred -fggreen -bggreen -fgblue -bgblue
        -fgbright -bgbright
    } {
        if {($flags & [_console_output_attr $attr]) == [_console_output_attr $attr]} {
            lappend attrs $attr 1
            set flags [expr {$flags & ~ [_console_output_attr $attr]}]
            if {$flags == 0} {
                break
            }
        }
    }
        
    return $attrs
}


# Get the current mode settings for the console
proc twapi::_get_console_input_mode {conh} {
    set mode [GetConsoleMode $conh]
    return [_bitmask_to_switches $mode [_console_input_mode_syms]]
}
interp alias {} twapi::get_console_input_mode {} twapi::_do_console_proc twapi::_get_console_input_mode stdin

# Get the current mode settings for the console
proc twapi::_get_console_output_mode {conh} {
    set mode [GetConsoleMode $conh]
    return [_bitmask_to_switches $mode [_console_output_mode_syms]]
}
interp alias {} twapi::get_console_output_mode {} twapi::_do_console_proc twapi::_get_console_output_mode stdout

# Set console input mode
proc twapi::_set_console_input_mode {conh args} {
    set mode [_switches_to_bitmask $args [_console_input_mode_syms]]
    # If insertmode or quickedit mode are set, make sure to set extended bit
    if {$mode & 0x60} {
        setbits mode 0x80;              # ENABLE_EXTENDED_FLAGS
    }

    SetConsoleMode $conh $mode
}
interp alias {} twapi::set_console_input_mode {} twapi::_do_console_proc twapi::_set_console_input_mode stdin

# Modify console input mode
proc twapi::_modify_console_input_mode {conh args} {
    set prev [GetConsoleMode $conh]
    set mode [_switches_to_bitmask $args [_console_input_mode_syms] $prev]
    # If insertmode or quickedit mode are set, make sure to set extended bit
    if {$mode & 0x60} {
        setbits mode 0x80;              # ENABLE_EXTENDED_FLAGS
    }

    SetConsoleMode $conh $mode
    # Returns the old modes
    return [_bitmask_to_switches $prev [_console_input_mode_syms]]
}
interp alias {} twapi::modify_console_input_mode {} twapi::_do_console_proc twapi::_modify_console_input_mode stdin

#
# Set console output mode
proc twapi::_set_console_output_mode {conh args} {
    set mode [_switches_to_bitmask $args [_console_output_mode_syms]]

    SetConsoleMode $conh $mode

}
interp alias {} twapi::set_console_output_mode {} twapi::_do_console_proc twapi::_set_console_output_mode stdout

# Set console output mode
proc twapi::_modify_console_output_mode {conh args} {
    set prev [GetConsoleMode $conh]
    set mode [_switches_to_bitmask $args [_console_output_mode_syms] $prev]

    SetConsoleMode $conh $mode
    # Returns the old modes
    return [_bitmask_to_switches $prev [_console_output_mode_syms]]
}
interp alias {} twapi::modify_console_output_mode {} twapi::_do_console_proc twapi::_modify_console_output_mode stdout


# Create and return a handle to a screen buffer
proc twapi::create_console_screen_buffer {args} {
    array set opts [parseargs args {
        {inherit.bool 0}
        {mode.arg readwrite {read write readwrite}}
        {secd.arg ""}
        {share.arg readwrite {none read write readwrite}}
    } -maxleftover 0]

    switch -exact -- $opts(mode) {
        read       { set mode [_access_rights_to_mask generic_read] }
        write      { set mode [_access_rights_to_mask generic_write] }
        readwrite  {
            set mode [_access_rights_to_mask {generic_read generic_write}]
        }
    }
    switch -exact -- $opts(share) {
        none {
            set share 0
        }
        read       {
            set share 1 ;# FILE_SHARE_READ
        }
        write      {
            set share 2 ;# FILE_SHARE_WRITE
        }
        readwrite  {
            set share 3
        }
    }
    
    return [CreateConsoleScreenBuffer \
                $mode \
                $share \
                [_make_secattr $opts(secd) $opts(inherit)] \
                1]
}

# Retrieve information about a console screen buffer
proc twapi::_get_console_screen_buffer_info {conh args} {
    array set opts [parseargs args {
        all
        textattr
        cursorpos
        maxwindowsize
        size
        windowlocation
        windowpos
        windowsize
    } -maxleftover 0]

    lassign [GetConsoleScreenBufferInfo $conh] size cursorpos textattr windowlocation maxwindowsize

    set result [list ]
    foreach opt {size cursorpos maxwindowsize windowlocation} {
        if {$opts($opt) || $opts(all)} {
            lappend result -$opt [set $opt]
        }
    }

    if {$opts(windowpos) || $opts(all)} {
        lappend result -windowpos [lrange $windowlocation 0 1]
    }

    if {$opts(windowsize) || $opts(all)} {
        lassign $windowlocation left top right bot
        lappend result -windowsize [list [expr {$right-$left+1}] [expr {$bot-$top+1}]]
    }

    if {$opts(textattr) || $opts(all)} {
        lappend result -textattr [_flags_to_console_output_attr $textattr]
    }

    return $result
}
interp alias {} twapi::get_console_screen_buffer_info {} twapi::_do_console_proc twapi::_get_console_screen_buffer_info stdout

# Set the cursor position
proc twapi::_set_console_cursor_position {conh pos} {
    SetConsoleCursorPosition $conh $pos
}
interp alias {} twapi::set_console_cursor_position {} twapi::_do_console_proc twapi::_set_console_cursor_position stdout

# Get the cursor position
proc twapi::get_console_cursor_position {conh} {
    return [lindex [get_console_screen_buffer_info $conh -cursorpos] 1]
}

# Write the specified string to the console
proc twapi::_console_write {conh s args} {
    # Note writes are always in raw mode, 
    # TBD - support for  scrolling
    # TBD - support for attributes

    array set opts [parseargs args {
        position.arg
        {newlinemode.arg column {line column}}
        {restoreposition.bool 0}
    } -maxleftover 0]

    # Get screen buffer info including cursor position
    array set csbi [get_console_screen_buffer_info $conh -cursorpos -size]

    # Get current console mode for later restoration
    # If console is in processed mode, set it to raw mode
    set oldmode [get_console_output_mode $conh]
    set processed_index [lsearch -exact $oldmode "processed"]
    if {$processed_index >= 0} {
        # Console was in processed mode. Set it to raw mode
        set newmode [lreplace $oldmode $processed_index $processed_index]
        set_console_output_mode $conh $newmode
    }
    
    trap {
        # x,y are starting position to write
        if {[info exists opts(position)]} {
            lassign [_parse_integer_pair $opts(position)] x y
        } else {
            # No position specified, get current cursor position
            lassign $csbi(-cursorpos) x y
        }
        
        set startx [expr {$opts(newlinemode) == "column" ? $x : 0}]

        # Get screen buffer limits
        lassign  $csbi(-size)  width height

        # Ensure line terminations are just \n
        set s [string map [list \r\n \n] $s]

        # Write out each line at ($x,$y)
        # Either \r or \n is considered a newline
        foreach line [split $s \r\n] {
            if {$y >= $height} break
            set_console_cursor_position $conh [list $x $y]
            if {$x < $width} {
                # Write the characters - do not write more than buffer width
                set num_chars [expr {$width-$x}]
                if {[string length $line] < $num_chars} {
                    set num_chars [string length $line]
                }
                WriteConsole $conh $line $num_chars
            }
            
            
            # Calculate starting position of next line
            incr y
            set x $startx
        }

    } finally {
        # Restore cursor if requested
        if {$opts(restoreposition)} {
            set_console_cursor_position $conh $csbi(-cursorpos)
        }
        # Restore output mode if changed
        if {[info exists newmode]} {
            set_console_output_mode $conh $oldmode
        }
    }

    return
}
interp alias {} twapi::write_console {} twapi::_do_console_proc twapi::_console_write stdout
interp alias {} twapi::console_write {} twapi::_do_console_proc twapi::_console_write stdout

# Fill an area of the console with the specified attribute
proc twapi::_fill_console {conh args} {
    array set opts [parseargs args {
        position.arg
        numlines.int
        numcols.int
        {mode.arg column {line column}}
        window.bool
        fillchar.arg
    } -ignoreunknown]

    # args will now contain attribute switches if any
    set attr [_console_output_attr_to_flags $args]

    # Get screen buffer info for window and size of buffer
    array set csbi [get_console_screen_buffer_info $conh -windowpos -windowsize -size]
    # Height and width of the console
    lassign $csbi(-size) conx cony

    # Figure out what area we want to fill
    # startx,starty are starting position to write
    # sizex, sizey are the number of rows/lines
    if {[info exists opts(window)]} {
        if {[info exists opts(numlines)] || [info exists opts(numcols)]
            || [info exists opts(position)]} {
            error "Option -window cannot be used togther with options -position, -numlines or -numcols"
        }
        lassign  [_parse_integer_pair $csbi(-windowpos)] startx starty
        lassign  [_parse_integer_pair $csbi(-windowsize)] sizex sizey
    } else {
        if {[info exists opts(position)]} {
            lassign [_parse_integer_pair $opts(position)] startx starty
        } else {
            set startx 0
            set starty 0
        }
        if {[info exists opts(numlines)]} {
            set sizey $opts(numlines)
        } else {
            set sizey $cony
        }
        if {[info exists opts(numcols)]} {
            set sizex $opts(numcols)
        } else {
            set sizex [expr {$conx - $startx}]
        }
    }
    
    set firstcol [expr {$opts(mode) == "column" ? $startx : 0}]

    # Fill attribute at ($x,$y)
    set x $startx
    set y $starty
    while {$y < $cony && $y < ($starty + $sizey)} {
        if {$x < $conx} {
            # Write the characters - do not write more than buffer width
            set max [expr {$conx-$x}]
            if {[info exists attr]} {
                FillConsoleOutputAttribute $conh $attr [expr {$sizex > $max ? $max : $sizex}] [list $x $y]
            }
            if {[info exists opts(fillchar)]} {
                FillConsoleOutputCharacter $conh $opts(fillchar) [expr {$sizex > $max ? $max : $sizex}] [list $x $y]
            }
        }
        
        # Calculate starting position of next line
        incr y
        set x $firstcol
    }
    
    return
}
interp alias {} twapi::fill_console {} twapi::_do_console_proc twapi::_fill_console stdout

# Clear the console
proc twapi::_clear_console {conh args} {
    # I support we could just call fill_console but this code was already
    # written and is faster
    array set opts [parseargs args {
        {fillchar.arg " "}
        {windowonly.bool 0}
    } -maxleftover 0]

    array set cinfo [get_console_screen_buffer_info $conh -size -windowpos -windowsize]
    lassign  $cinfo(-size) width height
    if {$opts(windowonly)} {
        # Only clear portion visible in the window. We have to do this
        # line by line since we do not want to erase text scrolled off
        # the window either in the vertical or horizontal direction
        lassign $cinfo(-windowpos) x y
        lassign $cinfo(-windowsize) w h
        for {set i 0} {$i < $h} {incr i} {
            FillConsoleOutputCharacter \
                $conh \
                $opts(fillchar)  \
                $w \
                [list $x [expr {$y+$i}]]
        }
    } else {
        FillConsoleOutputCharacter \
            $conh \
            $opts(fillchar)  \
            [expr {($width*$height) }] \
            [list 0 0]
    }
    return
}
interp alias {} twapi::clear_console {} twapi::_do_console_proc twapi::_clear_console stdout
#
# Flush console input
proc twapi::_flush_console_input {conh} {
    FlushConsoleInputBuffer $conh
}
interp alias {} twapi::flush_console_input {} twapi::_do_console_proc twapi::_flush_console_input stdin

# Return number of pending console input events
proc twapi::_get_console_pending_input_count {conh} {
    return [GetNumberOfConsoleInputEvents $conh]
}
interp alias {} twapi::get_console_pending_input_count {} twapi::_do_console_proc twapi::_get_console_pending_input_count stdin

# Generate a console control event
proc twapi::generate_console_control_event {event {procgrp 0}} {
    switch -exact -- $event {
        ctrl-c {set event 0}
        ctrl-break {set event 1}
        default {error "Invalid event definition '$event'"}
    }
    GenerateConsoleCtrlEvent $event $procgrp
}

# Get number of mouse buttons
proc twapi::num_console_mouse_buttons {} {
    return [GetNumberOfConsoleMouseButtons]
}

# Get console title text
proc twapi::get_console_title {} {
    return [GetConsoleTitle]
}

# Set console title text
proc twapi::set_console_title {title} {
    return [SetConsoleTitle $title]
}

# Get the handle to the console window
proc twapi::get_console_window {} {
    return [GetConsoleWindow]
}

# Get the largest console window size
proc twapi::_get_console_window_maxsize {conh} {
    return [GetLargestConsoleWindowSize $conh]
}
interp alias {} twapi::get_console_window_maxsize {} twapi::_do_console_proc twapi::_get_console_window_maxsize stdout

proc twapi::_set_console_active_screen_buffer {conh} {
    SetConsoleActiveScreenBuffer $conh
}
interp alias {} twapi::set_console_active_screen_buffer {} twapi::_do_console_proc twapi::_set_console_active_screen_buffer stdout

# Set the size of the console screen buffer
proc twapi::_set_console_screen_buffer_size {conh size} {
    SetConsoleScreenBufferSize $conh [_parse_integer_pair $size]
}
interp alias {} twapi::set_console_screen_buffer_size {} twapi::_do_console_proc twapi::_set_console_screen_buffer_size stdout

# Set the default text attribute
proc twapi::_set_console_default_attr {conh args} {
    SetConsoleTextAttribute $conh [_console_output_attr_to_flags $args]
}
interp alias {} twapi::set_console_default_attr {} twapi::_do_console_proc twapi::_set_console_default_attr stdout

# Set the console window position
proc twapi::_set_console_window_location {conh rect args} {
    array set opts [parseargs args {
        {absolute.bool true}
    } -maxleftover 0]

    SetConsoleWindowInfo $conh $opts(absolute) $rect
}
interp alias {} twapi::set_console_window_location {} twapi::_do_console_proc twapi::_set_console_window_location stdout

proc twapi::get_console_window_location {conh} {
    return [lindex [get_console_screen_buffer_info $conh -windowlocation] 1]
}

# Get the console code page
proc twapi::get_console_output_codepage {} {
    return [GetConsoleOutputCP]
}

# Set the console code page
proc twapi::set_console_output_codepage {cp} {
    SetConsoleOutputCP $cp
}

# Get the console input code page
proc twapi::get_console_input_codepage {} {
    return [GetConsoleCP]
}

# Set the console input code page
proc twapi::set_console_input_codepage {cp} {
    SetConsoleCP $cp
}

# Read a line of input
proc twapi::_console_read {conh args} {
    if {[llength $args]} {
        set oldmode [modify_console_input_mode $conh {*}$args]
    }
    trap {
        return [ReadConsole $conh 1024]
    } finally {
        if {[info exists oldmode]} {
            set_console_input_mode $conh {*}$oldmode
        }
    }
}
interp alias {} twapi::console_read {} twapi::_do_console_proc twapi::_console_read stdin

proc twapi::_map_console_controlkeys {control} {
    return [_make_symbolic_bitmask $control {
        capslock 0x80
        enhanced 0x100
        leftalt 0x2
        leftctrl 0x8
        numlock 0x20
        rightalt 0x1
        rightctrl 4
        scrolllock 0x40
        shift 0x10
    } 0]
}

proc twapi::_console_read_input_records {conh args} {
    parseargs args {
        {count.int 1}
        peek
    } -setvars -maxleftover 0
    set recs {}
    if {$peek} {
        set input [PeekConsoleInput $conh $count]
    } else {
        set input [ReadConsoleInput $conh $count]
    }
    foreach rec $input {
        switch [format %d [lindex $rec 0]] {
            1 {
                lassign [lindex $rec 1] keydown repeat keycode scancode char controlstate
                lappend recs \
                    [list key [list \
                                   keystate [expr {$keydown ? "down" : "up"}] \
                                   repeat $repeat keycode $keycode \
                                   scancode $scancode char $char \
                                   controls [_map_console_controlkeys $controlstate]]]
            }
            2 {
                lassign [lindex $rec 1] position buttonstate controlstate flags
                set buttons {}
                if {[expr {$buttonstate & 0x1}]} {lappend buttons left}
                if {[expr {$buttonstate & 0x2}]} {lappend buttons right}
                if {[expr {$buttonstate & 0x4}]} {lappend buttons left2}
                if {[expr {$buttonstate & 0x8}]} {lappend buttons left3}
                if {[expr {$buttonstate & 0x10}]} {lappend buttons left4}
                if {$flags & 0x8} {
                    set horizontalwheel [expr {$buttonstate >> 16}]
                } else {
                    set horizontalwheel 0
                }
                if {$flags & 0x4} {
                    set verticalwheel [expr {$buttonstate >> 16}]
                } else {
                    set verticalwheel 0
                }
                lappend recs \
                    [list mouse [list \
                                     position $position \
                                     buttons $buttons \
                                     controls [_map_console_controlkeys $controlstate] \
                                     doubleclick [expr {$flags & 0x2}] \
                                     horizontalwheel $horizontalwheel \
                                     moved [expr {$flags & 0x1}] \
                                     verticalwheel $verticalwheel]]
            }
            default {
                lappend recs [list \
                                  [dict* {4 buffersize 8 menu 16 focus} [lindex $rec 0]] \
                                  [lindex $rec 1]]
            }
        }
    }
    return $recs
}
interp alias {} twapi::console_read_input_records {} twapi::_do_console_proc twapi::_console_read_input_records stdin

# Set up a console handler
proc twapi::_console_ctrl_handler {ctrl} {
    variable _console_control_script
    if {[info exists _console_control_script]} {
        return [uplevel #0 [linsert $_console_control_script end $ctrl]]
    }
    return 0;                   # Not handled
}
proc twapi::set_console_control_handler {script} {
    variable _console_control_script
    if {[string length $script]} {
        if {![info exists _console_control_script]} {
            Twapi_ConsoleEventNotifier 1
        }
        set _console_control_script $script
    } else {
        if {[info exists _console_control_script]} {
            Twapi_ConsoleEventNotifier 0
            unset _console_control_script
        }
    }
}

# 
# Utilities
#

# Helper to call a proc after doing a stdin/stdout/stderr -> handle
# mapping. The handle is closed after calling the proc. The first
# arg in $args must be the console handle if $args is not an empty list
proc twapi::_do_console_proc {proc default args} {
    if {[llength $args] == 0} {
        set args [list $default]
    }
    set conh [lindex $args 0]
    switch -exact -- [string tolower $conh] {
        stdin  -
        stdout -
        stderr {
            set real_handle [get_console_handle $conh]
            trap {
                lset args 0 $real_handle
                return [uplevel 1 [list $proc] $args]
            } finally {
                CloseHandle $real_handle
            }
        }
    }
    
    return [uplevel 1 [list $proc] $args]
}

proc twapi::_console_input_mode_syms {} {
    return {
        -processedinput 0x0001
        -lineinput      0x0002
        -echoinput      0x0004
        -windowinput    0x0008
        -mouseinput     0x0010
        -insertmode     0x0020
        -quickeditmode  0x0040
        -extendedmode   0x0080
        -autoposition   0x0100
    }
}

proc twapi::_console_output_mode_syms {} {
    return { -processedoutput 1 -wrapoutput 2 }
}

twapi::proc* twapi::_console_output_attr {sym} {
    variable _console_output_attr_syms
    array set _console_output_attr_syms {
        -fgblue 1
        -fggreen 2
        -fgturquoise 3
        -fgred 4
        -fgpurple 5
        -fgyellow 6
        -fggray 7
        -fgbright 8
        -fgwhite 15
        -bgblue 16
        -bggreen 32
        -bgturquoise 48
        -bgred 64
        -bgpurple 80
        -bgyellow 96
        -bggray 112
        -bgbright 128
        -bgwhite 240
    }
} {
    variable _console_output_attr_syms
    if {[info exists _console_output_attr_syms($sym)]} {
        return $_console_output_attr_syms($sym)
    }

    badargs! "Invalid console output attribute '$sym'" 3
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<














































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/crypto.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
1589
1590
1591
1592
1593
1594
1595
1596
1597
1598
1599
1600
1601
1602
1603
1604
1605
1606
1607
1608
1609
1610
1611
1612
1613
1614
1615
1616
1617
1618
1619
1620
1621
1622
1623
1624
1625
1626
1627
1628
1629
1630
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
1652
1653
1654
1655
1656
1657
1658
1659
1660
1661
1662
1663
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
1697
1698
1699
1700
1701
1702
1703
1704
1705
1706
1707
1708
1709
1710
1711
1712
1713
1714
1715
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
1747
1748
1749
1750
1751
1752
1753
1754
1755
1756
1757
1758
1759
1760
1761
1762
1763
1764
1765
1766
1767
1768
1769
1770
1771
1772
1773
1774
1775
1776
1777
1778
1779
1780
1781
1782
1783
1784
1785
1786
1787
1788
1789
1790
1791
1792
1793
1794
1795
1796
1797
1798
1799
1800
1801
1802
1803
1804
1805
1806
1807
1808
1809
1810
1811
1812
1813
1814
1815
1816
1817
1818
1819
1820
1821
1822
1823
1824
1825
1826
1827
1828
1829
1830
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
1858
1859
1860
1861
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874
1875
1876
1877
1878
1879
1880
1881
1882
1883
1884
1885
1886
1887
1888
1889
1890
1891
1892
1893
1894
1895
1896
1897
1898
1899
1900
1901
1902
1903
1904
1905
1906
1907
1908
1909
1910
1911
1912
1913
1914
1915
1916
1917
1918
1919
1920
1921
1922
1923
1924
1925
1926
1927
1928
1929
1930
1931
1932
1933
1934
1935
1936
1937
1938
1939
1940
1941
1942
1943
1944
1945
1946
1947
1948
1949
1950
1951
1952
1953
1954
1955
1956
1957
1958
1959
1960
1961
1962
1963
1964
1965
1966
1967
1968
1969
1970
1971
1972
1973
1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040
2041
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053
2054
2055
2056
2057
2058
2059
2060
2061
2062
2063
#
# Copyright (c) 2007-2014, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

namespace eval twapi {}

### Data protection

proc twapi::protect_data {data args} {

    # Not used because doesn't seem to have any effect 
    # {promptonunprotect.bool 0 0x1}
    parseargs args {
        {description.arg ""}
        {localmachine.bool 0 0x4}
        {noui.bool 0 0x1}
        {audit.bool 0 0x10}
        {hwnd.arg NULL}
        prompt.arg
    } -setvars -maxleftover 0

    if {[info exists prompt]} {
        # 2 -> PROMPTONPROTECT
        set prompt [list 2 $hwnd $prompt]
    } else {
        set prompt {}
    }

    return [CryptProtectData $data $description "" "" $prompt [expr {$localmachine | $noui | $audit}]]
}

proc twapi::unprotect_data {data args} {
    # Do not seem to have any effect
    # {promptonunprotect.bool 0 0x1}
    # {promptonprotect.bool 0 0x2}
    parseargs args {
        {withdescription.bool 0}
        {noui.bool 0 0x1}
        {hwnd.arg NULL}
        prompt.arg
    } -setvars -maxleftover 0

    if {[info exists prompt]} {
        # 2 -> PROMPTONPROTECT
        set prompt [list 2 $hwnd $prompt]
    } else {
        set prompt {}
    }

    set data [CryptUnprotectData $data "" "" $prompt $noui]
    if {$withdescription} {
        return $data
    } else {
        return [lindex $data 0]
    }
}



################################################################
# Certificate Stores

# Close a certificate store
proc twapi::cert_store_release {hstore} {
    CertCloseStore $hstore 0
    return
}

proc twapi::cert_temporary_store {args} {
    parseargs args {
        {encoding.arg der {der cer crt pem base64}}
        serialized.arg
        pkcs7.arg
        {password.arg ""}
        pfx.arg
        pkcs12.arg
        {exportableprivatekeys.bool 0 1}
        {userprotected.bool 0 2}
        keysettype.arg
    } -setvars -maxleftover 0
    
    set nformats 0
    foreach format {serialized pkcs7 pfx pkcs12} {
        if {[info exists $format]} {
            set data [set $format]
            incr nformats
        }
    }
    if {$nformats > 1} {
        badargs! "At most one of -pfx, -pkcs12, -pkcs7 or -serialized may be specified."
    }
    if {$nformats == 0} {
        # 2 -> CERT_STORE_PROV_MEMORY 
        return [CertOpenStore 2 0 NULL 0 ""]
    }
    
    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING

    if {[info exists serialized]} {
        # 6 -> CERT_STORE_PROV_SERIALIZED
        return [CertOpenStore 6 0x10001 NULL 0 $data]
    }

    if {[info exists pkcs7]} {
        if {$encoding in {pem base64}} {
            # 6 -> CRYPT_STRING_BASE64_ANY 
            set data [CryptStringToBinary $data 6]
        }
        # 5 -> CERT_STORE_PROV_PKCS7
        return [CertOpenStore 5 0x10001 NULL 0 $data]
    }

    # PFX/PKCS12
    if {[string length $password] == 0} {
        set password [conceal ""]
    }
    set flags 0
    if {[info exists keysettype]} {
        set flags [dict! {user 0x1000 machine 0x20} $keysettype]
    }

    set flags [tcl::mathop::| $flags $exportableprivatekeys $userprotected]
    return [PFXImportCertStore $data $password $flags]
}

proc twapi::cert_file_store_open {path args} {
    set flags [_parse_store_open_opts $args]

    if {! ($flags & 0x00008000)} {
        # If not readonly, set commitenable
        set flags [expr {$flags | 0x00010000}]
    }

    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
    # 8 -> CERT_STORE_PROV_FILENAME_W
    return [CertOpenStore 8 0x10001 NULL $flags [file nativename [file normalize $path]]]
}

proc twapi::cert_serialized_store_open {data args} {
    set flags [_parse_store_open_opts $args]

    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
    # 6 -> CERT_STORE_PROV_SERIALIZED
    return [CertOpenStore 6 0x10001 NULL $flags $data]
}



proc twapi::cert_physical_store_open {name location args} {
    variable _system_stores

    set flags [_parse_store_open_opts $args]
    incr flags [_system_store_id $location]
    # 14 -> CERT_STORE_PROV_PHYSICAL_W
    return [CertOpenStore 14 0 NULL $flags $name]
}

proc twapi::cert_physical_store_delete {name location} {
    set flags 0x10;             # CERT_STORE_DELETE_FLAG
    incr flags [_system_store_id $location]
    
    # 14 -> CERT_STORE_PROV_PHYSICAL_W
    return [CertOpenStore 14 0 NULL $flags $name]
}

# TBD - document and figure out what format to return data in
proc twapi::cert_physical_stores {system_store_name location} {
    return [CertEnumPhysicalStore $system_store_name [_system_store_id $location]]
}

proc twapi::cert_system_store_open {name args} {
    variable _system_stores

    if {[llength $args] == 0} {
        return [CertOpenSystemStore $name]
    }

    set flags [_parse_store_open_opts [lassign $args location]]
    incr flags [_system_store_id $location]
    return [CertOpenStore 10 0 NULL $flags $name]
}

proc twapi::cert_system_store_delete {name location} {
    set flags 0x10;             # CERT_STORE_DELETE_FLAG
    incr flags [_system_store_id $location]
    return [CertOpenStore 10 0 NULL $flags $name]
}

proc twapi::cert_system_store_locations {} {
    set l {}
    foreach e [CertEnumSystemStoreLocation 0] {
        lappend l [lindex $e 0]
    }
    return $l
}

proc twapi::cert_system_stores {location} {
    set l {}
    foreach e [CertEnumSystemStore [_system_store_id $location] ""] {
        lappend l [lindex $e 0]
    }
    return $l
}

# TBD - document?
proc twapi::cert_store_iterate {hstore varname script {type any} {term {}}} {
    upvar 1 $varname cert
    set cert NULL
    while {1} {
        set cert [cert_store_find_certificate $hstore $type $term $cert]
        if {$cert eq ""} break
        switch [catch {uplevel 1 $script} result options] {
            0 -
            4 {}
            3 {
                cert_release $cert
                set cert ""
                return
            }
            1 -
            default {
                cert_release $cert
                set cert ""
                return -options $options $result
            }
        }
    }
    return
}

proc twapi::cert_store_find_certificate {hstore {type any} {term {}} {hcert NULL}} {

    # TBD subject_cert 11<<16
    # TBD key_spec 9<<16

    set term_types {
        any 0
        existing 13<<16
        key_identifier 15<<16
        md5_hash 4<<16
        subject_public_key_md5_hash 18<<16
        sha1_hash 1<<16
        signature_hash 14<<16
        issuer_name (2<<16)|4
        subject_name  (2<<16)|7
        issuer_substring (8<<16)|4
        subject_substring (8<<16)|7
        property 5<<16
        public_key 6<<16
    }

    if {$type eq "property"} {
        set term [_cert_prop_id $term]
    }
    set type [expr [dict! $term_types $type 1]]

    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
    return [CertFindCertificateInStore $hstore 0x10001 0 $type $term $hcert]
}

proc twapi::cert_store_enum_contents {hstore {hcert NULL}} {
    return [CertEnumCertificatesInStore $hstore $hcert]
}

proc twapi::cert_store_add_certificate {hstore hcert args} {
    array set opts [_cert_add_parseargs args]
    return [CertAddCertificateContextToStore $hstore $hcert $opts(disposition)]
}

proc twapi::cert_store_add_encoded_certificate {hstore enccert args} {
    parseargs args {
        {encoding.arg der {der pem}}
    } -ignoreunknown -setvars
    array set opts [_cert_add_parseargs args]
    if {$encoding eq "pem"} {
        # 6 -> CRYPT_STRING_BASE64_ANY 
        set enccert [CryptStringToBinary $enccert 6]
    }
    return [CertAddEncodedCertificateToStore $hstore 0x10001 $enccert $opts(disposition)]
}

proc twapi::cert_store_export_pfx {hstore password args} {
    parseargs args {
        {exportprivatekeys.bool 0 0x4}
        {failonmissingkey.bool 0 0x1}
        {failonunexportablekey.bool 0 0x2}
    } -maxleftover 0 -setvars

    if {[string length $password] == 0} {
        set password [conceal ""]
    }

    # NOTE: the -fail* flags only take effect iff the certificate in the store
    # claims to have a private key but does not actually have one. It will
    # not fail if the cert does not actually claim to have a private key

    set flags [tcl::mathop::| $exportprivatekeys $failonunexportablekey $failonmissingkey]

    return [PFXExportCertStoreEx $hstore $password {} $flags]
}
interp alias {} twapi::cert_store_export_pkcs12 {} twapi::cert_store_export_pfx

proc twapi::cert_store_commit {hstore args} {
    array set opts [parseargs args {
        {force.bool 0}
    } -maxleftover 0]
    
    return [Twapi_CertStoreCommit $hstore $opts(force)]
}

proc twapi::cert_store_serialize {hstore} {
    return [Twapi_CertStoreSerialize $hstore 1]
}

proc twapi::cert_store_export_pkcs7 {hstore args} {
    parseargs args {
        {encoding.arg der {der pem}}
    } -setvars -maxleftover 0
    
    set exp [Twapi_CertStoreSerialize $hstore 2]
    if {$encoding eq "pem"} {
        # 1 -> CRYPT_STRING_BASE64
        # 0x80000000 -> LF-only, not CRLF
        return "-----BEGIN PKCS7-----\n[CryptBinaryToString $exp 0x80000001]-----END PKCS7-----\n"
    } else {
        return $exp
    }
}

################################################################
# Certificates

interp alias {} twapi::cert_subject_name {} twapi::_cert_get_name subject
interp alias {} twapi::cert_issuer_name {} twapi::_cert_get_name issuer
proc twapi::_cert_get_name {field hcert args} {

    switch $field {
        subject { set field 0 }
        issuer  { set field 1 }
        default { badargs! "Invalid name type '$field': must be \"subject\" or \"issuer\"."
        }
    }
    array set opts [parseargs args {
        {name.arg oid_common_name}
        {separator.arg comma {comma semicolon newline}}
        {reverse.bool 0 0x02000000}
        {noquote.bool 0 0x10000000}
        {noplus.bool  0 0x20000000}
        {format.arg x500 {x500 oid simple}}
    } -maxleftover 0]

    set arg ""
    switch $opts(name) {
        email { set what 1 }
        simpledisplay { set what 4 }
        friendlydisplay {set what 5 }
        dns { set what 6 }
        url { set what 7 }
        upn { set what 8 }
        rdn {
            set what 2
            switch $opts(format) {
                simple {set arg 1}
                oid {set arg 2}
                x500 -
                default {set arg 3}
            }
            set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}]
            switch $opts(separator) {
                semicolon    { set arg [expr {$arg | 0x40000000}] }
                newline { set arg [expr {$arg | 0x08000000}] }
            }
        }
        default {
            set what 3;         # Assume OID
            set arg [oid $opts(name)]
        }
    }

    return [CertGetNameString $hcert $what $field $arg]

}

proc twapi::cert_blob_to_name {blob args} {
    array set opts [parseargs args {
        {format.arg x500 {x500 oid simple}}
        {separator.arg comma {comma semi newline}}
        {reverse.bool 0 0x02000000}
        {noquote.bool 0 0x10000000}
        {noplus.bool  0 0x20000000}
    } -maxleftover 0]

    switch $opts(format) {
        x500   {set arg 3}
        simple {set arg 1}
        oid    {set arg 2}
    }

    set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}]
    switch $opts(separator) {
        semi    { set arg [expr {$arg | 0x40000000}] }
        newline { set arg [expr {$arg | 0x08000000}] }
    }

    return [CertNameToStr $blob $arg]
}

proc twapi::cert_name_to_blob {name args} {
    array set opts [parseargs args {
        {format.arg x500 {x500 oid simple}}
        {separator.arg any {any comma semicolon newline}}
        {reverse.bool 0 0x02000000}
        {noquote.bool 0 0x10000000}
        {noplus.bool  0 0x20000000}
    } -maxleftover 0]

    switch $opts(format) {
        x500   {set arg 3}
        simple {set arg 1}
        oid    {set arg 2}
    }

    set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}]
    switch $opts(separator) {
        comma   { set arg [expr {$arg | 0x04000000}] }
        semicolon    { set arg [expr {$arg | 0x40000000}] }
        newline { set arg [expr {$arg | 0x08000000}] }
    }

    return [CertStrToName $name $arg]
}

proc twapi::cert_enum_properties {hcert args} {
    parseargs args {
        names
    } -setvars -maxleftover 0
    
    set id 0
    set ids {}
    while {[set id [CertEnumCertificateContextProperties $hcert $id]]} {
        if {$names} {
            lappend ids [_cert_prop_name $id]
        } else {
            lappend ids $id
        }
    }
    return $ids
}

proc twapi::cert_property {hcert prop} {
    # TBD - need to cook some properties - enhkey_usage

    if {[string is integer -strict $prop]} {
        return [CertGetCertificateContextProperty $hcert $prop]
    } else {
        return [CertGetCertificateContextProperty $hcert [_cert_prop_id $prop] 1]
    }
}

proc twapi::cert_property_set {hcert prop propval} {
    switch $prop {
        pvk_file -
        friendly_name -
        description {
            set val [encoding convertto unicode "${propval}\0"]
        }
        enhkey_usage {
            set val [::twapi::CryptEncodeObjectEx 2.5.29.37 [_get_enhkey_usage_oids $propval]]
        }
        default {
            badargs! "Invalid or unsupported property name \"$prop\". Must be one of [join $unicode_props {, }]."
        }
    }

    CertSetCertificateContextProperty $hcert [_cert_prop_id $prop] 0 $val
}

proc twapi::cert_property_delete {hcert prop} {
    CertSetCertificateContextProperty $hcert [_cert_prop_id $prop] 0
}

# TBD - Also add cert_set_key_prov_from_crypt_context
proc twapi::cert_set_key_prov {hcert args} {
    # TB - make keycontainer explicit arg
    parseargs args {
        keycontainer.arg
        csp.arg
        {csptype.arg prov_rsa_full}
        {keysettype.arg user {user machine}}
        {silent.bool 0 0x40}
        {keyspec.arg signature {keyexchange signature}}
    } -maxleftover 0 -nulldefault -setvars

    set flags $silent
    if {$keysettype eq "machine"} {
        incr flags 0x20;        # CRYPT_KEYSET_MACHINE
    }

    # TBD - does the keyspec matter ? In case of self signed cert
    # which (keyexchange/signature) or both have to be specified ?

    # 2 -> CERT_KEY_PROV_INFO_PROP_ID
    # TBD - the provider param is hardcoded as {}. Should that be an option ?
    CertSetCertificateContextProperty $hcert 2 0 \
        [list $keycontainer $csp [_csp_type_name_to_id $csptype] $flags {} [_crypt_keyspec $keyspec]]
    return
}

proc twapi::cert_export {hcert args} {
    parseargs args {
        {encoding.arg der {der pem}}
    } -maxleftover 0 -setvars

    set enc [lindex [Twapi_CertGetEncoded $hcert] 1]
    if {$encoding eq "pem"} {
        # 0 -> CRYPT_STRING_BASE64HEADER 
        # 0x80000000 -> LF-only, not CRLF
        return [CryptBinaryToString $enc 0x80000000]
    } else {
        return $enc
    }
}

proc twapi::cert_import {enccert args} {
    parseargs args {
        {encoding.arg der {der pem}}
    } -maxleftover 0 -setvars

    if {$encoding eq "pem"} {
        # 6 -> CRYPT_STRING_BASE64_ANY 
        set enccert [CryptStringToBinary $enccert 6]
    }

    return [CertCreateCertificateContext 0x10001 $enccert]
}


proc twapi::cert_enhkey_usage {hcert {loc both}} {
    return [_cert_decode_enhkey [CertGetEnhancedKeyUsage $hcert [dict! {property 4 extension 2 both 0} $loc 1]]]
}

proc twapi::cert_key_usage {hcert} {
    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
    return [_cert_decode_keyusage [Twapi_CertGetIntendedKeyUsage 0x10001 $hcert]]
}

proc twapi::cert_thumbprint {hcert} {
    binary scan [cert_property $hcert sha1_hash] H* hash
    return $hash
}

proc twapi::cert_info {hcert} {
    return [twine {
        -version -serialnumber -signaturealgorithm -issuer
        -start -end -subject -publickey -issuerid -subjectid -extensions} \
                [Twapi_CertGetInfo $hcert]]
}

proc twapi::cert_extension {hcert oid} {
    set ext [CertFindExtension $hcert [oid $oid]]
    if {[llength $ext] == 0} {
        return $ext
    }
    lassign $ext oid critical val
    return [list $critical [_cert_decode_extension $oid $val]]
}

proc twapi::cert_create_self_signed {subject args} {
    set args [_cert_create_parse_options $args opts]

    # TBD - make keycontainer explicit arg
    array set opts [parseargs args {
        {keyspec.arg signature {keyexchange signature}}
        {keycontainer.arg {}}
        {keysettype.arg user {machine user}}
        {silent.bool 0 0x40}
        {csp.arg {}}
        {csptype.arg {prov_rsa_full}}
        {signaturealgorithm.arg {}}
    } -maxleftover 0 -ignoreunknown]

    set name_blob [cert_name_to_blob $subject]

    set kiflags $opts(silent)
    if {$opts(keysettype) eq "machine"} {
        incr kiflags 0x20;  # CRYPT_MACHINE_KEYSET
    }
    set keyinfo [list \
                     $opts(keycontainer) \
                     $opts(csp) \
                     [_csp_type_name_to_id $opts(csptype)] \
                     $kiflags \
                     {} \
                     [_crypt_keyspec $opts(keyspec)]]
    
    set flags 0;                # Always 0 for now
    return [CertCreateSelfSignCertificate NULL $name_blob $flags $keyinfo \
                [_make_algorithm_identifier $opts(signaturealgorithm)] \
                $opts(start) $opts(end) $opts(extensions)]
}

proc twapi::cert_create_self_signed_from_crypt_context {subject hprov args} {
    set args [_cert_create_parse_options $args opts]

    array set opts [parseargs args {
        {signaturealgorithm.arg {}}
    } -maxleftover 0]

    set name_blob [cert_name_to_blob $subject]

    set flags 0;                # Always 0 for now
    return [CertCreateSelfSignCertificate $hprov $name_blob $flags {} \
                [_make_algorithm_identifier $opts(signaturealgorithm)] \
                $opts(start) $opts(end) $opts(extensions)]
}

proc twapi::cert_create {subject pubkey cissuer args} {
    set args [_cert_create_parse_options $args opts]

    parseargs args {
        {keyspec.arg signature {keyexchange signature}}
        {encoding.arg der {der pem}}
    } -maxleftover 0 -setvars
    
    # TBD - check that issuer is a CA

    set issuer_info [cert_info $cissuer]
    set issuer_blob [cert_name_to_blob [dict get $issuer_info -subject] -format x500]
    set sigalgo [dict get $issuer_info -signaturealgorithm]

    # If issuer cert has altnames, use they as issuer altnames for new cert
    set issuer_altnames [lindex [cert_extension $cissuer 2.5.29.17] 1]
    if {[llength $issuer_altnames]} {
        lappend opts(extensions) [_make_altnames_ext $issuer_altnames 0 1]
    }

    # The subject key id in issuer's cert will become the
    # authority key id in the new cert
    # TBD - if fail, get the CERT_KEY_IDENTIFIER_PROP_ID
    # 2.5.29.14 -> oid_subject_key_identifier
    set issuer_subject_key_id [cert_extension $cissuer 2.5.29.14]
    if {[string length [lindex $issuer_subject_key_id 1]] } {
        # 2.5.29.35 -> oid_authority_key_identifier
        lappend opts(extensions) [list 2.5.29.35 0 [list [lindex $issuer_subject_key_id 1] {} {}]]
    }

    # Generate a subject key identifier for this cert based on a hash
    # of the public key
    set subject_key_id [Twapi_HashPublicKeyInfo $pubkey]
    lappend opts(extensions) [list 2.5.29.14 0 $subject_key_id]

    set start [timelist_to_large_system_time $opts(start)]
    set end [timelist_to_large_system_time $opts(end)]

    # 2 -> CERT_V3
    # issuer_id and subject_id for the certificate are left empty
    # as recommended by gutman's X.509 paper
    set cert_info [list 2 $opts(serialnumber) $sigalgo $issuer_blob \
                       $start $end \
                       [cert_name_to_blob $subject] \
                       $pubkey {} {} \
                       $opts(extensions)]

    # We need to get the crypt provider for the issuer cert since
    # that is what will sign the new cert
    lassign [cert_property $cissuer key_prov_info] issuer_container issuer_provname issuer_provtype issuer_flags dontcare issuer_keyspec
    set hissuerprov [crypt_acquire $issuer_container -csp $issuer_provname -csptype $issuer_provtype -keysettype [expr {$issuer_flags & 0x20 ? "machine" : "user"}]]
    trap {
        # 0x10001 -> X509_ASN_ENCODING, 2 -> X509_CERT_TO_BE_SIGNED
        set enc [CryptSignAndEncodeCertificate $hissuerprov $issuer_keyspec \
                      0x10001 2 $cert_info $sigalgo]

        if {$encoding eq "pem"} {
            # 0 -> CRYPT_STRING_BASE64HEADER 
            # 0x80000000 -> LF-only, not CRLF
            return [CryptBinaryToString $enc 0x80000000]
        } else {
            return $enc
        }
    } finally {
        # TBD - test to make sure ok to close this if caller had
        # it open
        crypt_free $hissuerprov
    }
}

proc twapi::cert_tls_verify {hcert args} {

    parseargs args {
        {ignoreerrors.arg {}}
        {cacheendcert.bool 0 0x1}
        {revocationcheckcacheonly.bool 0 0x80000000}
        {urlretrievalcacheonly.bool 0 0x4}
        {disablepass1qualityfiltering.bool 0 0x40}
        {returnlowerqualitycontexts.bool 0 0x80}
        {disableauthrootautoupdate.bool 0 0x100}
        {revocationcheck.arg all {none all leaf excluderoot}}
        usageall.arg
        usageany.arg 
        {engine.arg user {user machine}}
        {timestamp.arg ""}
        {hstore.arg NULL}
        {trustedroots.arg}
        server.arg
    } -setvars -maxleftover 0

    set flags [dict! {none 0 all 0x20000000 leaf 0x10000000 excluderoot 0x40000000} $revocationcheck]
    set flags [tcl::mathop::| $flags $cacheendcert $revocationcheckcacheonly $urlretrievalcacheonly $disablepass1qualityfiltering $returnlowerqualitycontexts $disableauthrootautoupdate]

    set usage_op 1;             # USAGE_MATCH_TYPE_OR
    if {[info exists usageall]} {
        if {[info exists usageany]} {
            error "Only one of -usageall and -usageany may be specified"
        }
        set usage_op 0;         # USAGE_MATCH_TYPE_AND
        set usage [_get_enhkey_usage_oids $usageall]
    } elseif {[info exists usageany]} {
        set usage [_get_enhkey_usage_oids $usageany]
    } else {
        if {[info exists server]} {
            set usage [_get_enhkey_usage_oids [list server_auth]]
        } else {
            set usage [_get_enhkey_usage_oids [list client_auth]]
        }
    }

    set chainh [CertGetCertificateChain \
                    [dict* {user NULL machine {1 HCERTCHAINENGINE}} $engine] \
                    $hcert $timestamp $hstore \
                    [list [list $usage_op $usage]] $flags]
    
    trap {
        set verify_flags 0
        foreach ignore $ignoreerrors {
            set verify_flags [expr {$verify_flags | [dict! {
                time             0x07
                basicconstraints 0x08
                unknownca        0x10
                usage            0x20
                name             0x40
                policy           0x80
                revocation       0xf00
                criticalextensions 0x2000
            } $ignore]}]
        }

        if {[info exists server]} {
            set role 2;         # AUTHTYPE_SERVER
        } else {
            set role 1;         # AUTHTYPE_CLIENT
            set server ""
        }

        # I have no clue as to why some of these options have to
        # be specified in two different places
        set checks 0
        foreach {verify check} {
            0x7 0x2000
            0xf00 0x80
            0x10 0x100
            0x20 0x200
            0x40 0x1000
        } {
            if {$verify_flags & $verify} {
                set checks [expr {$checks | $check}]
            }
        }

        set status [Twapi_CertVerifyChainPolicySSL $chainh [list $verify_flags [list $role $checks $server]]]

        # If caller had provided additional trusted roots that are not
        # in the Windows trusted store, and the error is that the root is
        # untrusted, see if the root cert is one of the passed trusted ones
        if {$status == 0x800B0109 &&
            [info exists trustedroots] &&
            [llength $trustedroots]} {
            set chains [twapi::Twapi_CertChainContexts $chainh]
            set simple_chains [lindex $chains 1]
            # We will only deal when there is a single possible chain else
            # the recheck becomes very complicated as we are not sure if
            # the recheck will employ the same chain or not.
            if {[llength $simple_chains] == 1} {
                set certs_in_chain [lindex $simple_chains 0 1]
                # Get thumbprint of root cert
                set thumbprint [cert_thumbprint [lindex $certs_in_chain end 0]]
                # Match against each trusted root
                set trusted 0
                foreach trusted_cert $trustedroots {
                    if {$thumbprint eq [cert_thumbprint $trusted_cert]} {
                        set trusted 1
                        break
                    }
                }
                if {$trusted} {
                    # Yes, the root is trusted. It is not enough to
                    # say validation is ok because even if root
                    # is trusted, other errors might show up
                    # once untrusted roots are ignored. So we have
                    # to call the verification again.
                    # 0x10 -> CERT_CHAIN_POLICY_ALLOW_UNKNOWN_CA_FLAG
                    set verify_flags [expr {$verify_flags | 0x10}]
                    # 0x100 -> SECURITY_FLAG_IGNORE_UNKNOWN_CA
                    set checks [expr {$checks | 0x100}]
                    # Retry the call ignoring root errors
                    set status [Twapi_CertVerifyChainPolicySSL $chainh [list $verify_flags [list $role $checks $server]]]
                }
            }
        }

        return [dict*  {
            0x00000000 ok
            0x80096004 signature
            0x80092010 revoked
            0x800b0109 untrustedroot
            0x800b010d untrustedtestroot
            0x800b010a chaining
            0x800b0110 wrongusage
            0x800b0101 expired
            0x800b0114 name
            0x800b0113 policy
            0x80096019 basicconstraints
            0x800b0105 criticalextension
            0x800b0102 validityperiodnesting
            0x80092012 norevocationcheck
            0x80092013 revocationoffline
            0x800b010f cnmatch
            0x800b0106 purpose
            0x800b0103 carole
        } [hex32 $status]]
    } finally {
        if {[info exists certs_in_chain]} {
            foreach cert_stat $certs_in_chain {
                cert_release [lindex $cert_stat 0]
            }
        }
        CertFreeCertificateChain $chainh
    }

    return $status
}

proc twapi::cert_locate_private_key {hcert args} {
    parseargs args {
        {keysettype.arg any {any user machine}}
        {silent 0 0x40}
    } -maxleftover 0 -setvars
    
    return [CryptFindCertificateKeyProvInfo $hcert \
                [expr {$silent | [dict get {any 0 user 1 machine 2} $keysettype]}]]
}

proc twapi::cert_request_parse {req args} {
    parseargs args {
        {encoding.arg der {der pem}}
    } -setvars -maxleftover 0

    if {$encoding eq "pem"} {
        # 3 -> CRYPT_STRING_BASE64REQUESTHEADER 
        set req [CryptStringToBinary $req 3]
    }

    # 4 -> X509_CERT_REQUEST_TO_BE_SIGNED 
    lassign [::twapi::CryptDecodeObjectEx 4 $req] ver subject pubkey attrs
    lappend reqdict version $ver pubkey $pubkey attributes $attrs
    lappend reqdict subject [cert_blob_to_name $subject]
    foreach attr $attrs {
        lassign $attr oid values
        if {$oid eq "1.2.840.113549.1.9.14"} {
            # Extensions
            set extensions {}
            foreach ext [lindex $values 0] {
                lassign $ext oid critical value
                set value [_cert_decode_extension $oid $value]
                switch -exact -- $oid {
                    2.5.29.15 { set oidname -keyusage }
                    2.5.29.17 { set oidname -altnames }
                    2.5.29.19 { set oidname -basicconstraints }
                    2.5.29.37 { set oidname -enhkeyusage }
                    default { set oidname $oid }
                }
                lappend extensions $oidname [list $value $critical]
            }
            lappend reqdict extensions $extensions
        }
    }

    return $reqdict
}


proc twapi::cert_request_create {subject hprov keyspec args} {
    set args [_cert_create_parse_options $args opts]
    # TBD - barf if any elements other than extensions is set
    # TBD - document signaturealgorithmid
    parseargs args {
        {signaturealgorithmid.arg oid_rsa_sha1rsa}
        {encoding.arg der {der pem}}
    } -setvars -maxleftover 0
    
    set sigoid [oid $signaturealgorithmid]
    if {$sigoid ni [list [oid oid_rsa_sha1rsa] [oid oid_rsa_md5rsa] [oid oid_x957_sha1dsa]]} {
        badargs! "Invalid signature algorithm '$sigalg'"
    }
    set keyspec [twapi::_crypt_keyspec $keyspec]
    # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING
    # Pass oid_rsa_rsa as that seems to be what OPENSSL understands in
    # a CSR
    set pubkeyinfo [crypt_public_key $hprov $keyspec oid_rsa_rsa]
    set attrs [list 0 [cert_name_to_blob $subject] $pubkeyinfo]
    if {[llength $opts(extensions)]} {
        lappend attrs [list [list [oid oid_rsa_certextensions] [list $opts(extensions)]]]
    } else {
        lappend attrs {}
    }
    set req [CryptSignAndEncodeCertificate $hprov $keyspec 0x10001 4 $attrs $sigoid]
    if {$encoding eq "pem"} {
        # 3 -> CRYPT_STRING_BASE64REQUESTHEADER 
        # 0x80000000 -> LF-only, not CRLF
        return [CryptBinaryToString $req 0x80000003]
    } else {
        return $req
    }
}


################################################################
# Cryptographic context commands

proc twapi::crypt_acquire {keycontainer args} {
    parseargs args {
        csp.arg
        {csptype.arg prov_rsa_full}
        {keysettype.arg user {user machine}}
        {create.bool 0 0x8}
        {silent.bool 0 0x40}
        {verifycontext.bool 0 0xf0000000}
    } -maxleftover 0 -nulldefault -setvars
    
    # Based on http://support.microsoft.com/kb/238187, if verifycontext
    # is not specified, default container must not be used as keys
    # from different applications might overwrite. The docs for
    # CryptAcquireContext say keycontainer must be empty if verifycontext
    # is specified. Thus they are mutually exclusive.
    if {! $verifycontext} {
        if {$keycontainer eq ""} {
            badargs! "Option -verifycontext must be specified for the default key container."
        }
    }

    set flags [expr {$create | $silent | $verifycontext}]
    if {$keysettype eq "machine"} {
        incr flags 0x20;        # CRYPT_KEYSET_MACHINE
    }

    return [CryptAcquireContext $keycontainer $csp [_csp_type_name_to_id $csptype] $flags]
}

proc twapi::crypt_free {hcrypt} {
    twapi::CryptReleaseContext $hcrypt
}

proc twapi::crypt_key_container_delete {keycontainer args} {
    parseargs args {
        csp.arg
        {csptype.arg prov_rsa_full}
        {keysettype.arg user {machine user}}
        force
    } -maxleftover 0 -nulldefault -setvars

    if {$keycontainer eq "" && ! $force} {
        error "Default container cannot be deleted unless the -force option is specified"
    }

    set flags 0x10;             # CRYPT_DELETEKEYSET
    if {$keysettype eq "machine"} {
        incr flags 0x20;        # CRYPT_MACHINE_KEYSET
    }

    return [CryptAcquireContext $keycontainer $csp [_csp_type_name_to_id $csptype] $flags]
}

proc twapi::crypt_key_generate {hprov algid args} {

    array set opts [parseargs args {
        {archivable.bool 0 0x4000}
        {salt.bool 0 4}
        {exportable.bool 0 1}
        {pregen.bool 0x40}
        {userprotected.bool 0 2}
        {nosalt40.bool 0 0x10}
        {size.int 0}
    } -maxleftover 0]

    if {![string is integer -strict $algid]} {
        # See wincrypt.h in SDK
        switch -nocase -exact -- $algid {
            keyexchange {set algid 1}
            signature {set algid 2}
            default {
                set id [CertOIDToAlgId [oid $algid]]
                if {$id == 0} {
                    badargs! "Invalid algorithm id '$algid'"
                }
                set algid $id
            }
        }
    }

    if {$opts(size) < 0 || $opts(size) > 65535} {
        badargs! "Bad key size value '$size':  must be positive integer less than 65536"
    }

    return [CryptGenKey $hprov $algid [expr {($opts(size) << 16) | $opts(archivable) | $opts(salt) | $opts(exportable) | $opts(pregen) | $opts(userprotected) | $opts(nosalt40)}]]
}

proc twapi::crypt_keypair {hprov keyspec} {
    return [CryptGetUserKey $hprov [dict! {keyexchange 1 signature 2} $keyspec]]
}

# TBD - Document
proc twapi::crypt_public_key {hprov keyspec {sigoid oid_rsa_rsa}} {
    set pubkey [CryptExportPublicKeyInfoEx $hprov \
                    [_crypt_keyspec $keyspec] \
                    0x10001 \
                    [oid $sigoid] \
                    0]
}

proc twapi::crypt_get_security_descriptor {hprov} {
    return [CryptGetProvParam $hprov 8 7]
}

proc twapi::crypt_set_security_descriptor {hprov secd} {
    CryptSetProvParam $hprov 8 $secd
}

proc twapi::crypt_key_container_name {hprov} {
    return [_ascii_binary_to_string [CryptGetProvParam $hprov 6 0]]
}

proc twapi::crypt_key_container_unique_name {hprov} {
    return [_ascii_binary_to_string [CryptGetProvParam $hprov 36 0]]
}

proc twapi::crypt_csp {hprov} {
    return [_ascii_binary_to_string [CryptGetProvParam $hprov 4 0]]
}

proc twapi::crypt_csps {} {
    set i 0
    set result {}
    while {[llength [set csp [::twapi::CryptEnumProviders $i]]]} {
        lappend result [lreplace $csp 0 0 [_csp_type_id_to_name [lindex $csp 0]]]
        incr i
    }
    return $result
}

proc twapi::crypt_csptype {hprov} {
    binary scan [CryptGetProvParam $hprov 16 0] i i
    return [_csp_type_id_to_name $i]
}

proc twapi::crypt_csptypes {} {
    set i 0
    set result {}
    while {[llength [set csptype [::twapi::CryptEnumProviderTypes $i]]]} {
        lappend result [lreplace $csptype 0 0 [_csp_type_id_to_name [lindex $csptype 0]]]
        incr i
    }
    return $result
}

proc twapi::crypt_key_container_names {hprov} {
    return [CryptGetProvParam $hprov 2 0]
}

proc twapi::crypt_session_key_size {hprov} {
    binary scan [CryptGetProvParam $hprov 20 0] i i
    return $i
}

proc twapi::crypt_keyset_type {hprov} {
    binary scan [CryptGetProvParam $hprov 27 0] i i
    return [expr {$i & 0x20 ? "machine" : "user"}]
}

proc twapi::crypt_symmetric_key_size {hprov} {
    binary scan [CryptGetProvParam $hprov 19 0] i i
    return $i
}

###
# ASN.1 procs

# TBD - document
proc twapi::asn1_decode_string {bin} {
    # 24 -> X509_UNICODE_ANY_STRING
    return [lindex [twapi::CryptDecodeObjectEx 24 $bin] 1]
}

# TBD - document
proc twapi::asn1_encode_string {s {encformat utf8}} {
    # 24 -> X509_UNICODE_ANY_STRING
    return [twapi::CryptEncodeObjectEx 24 [list [dict! {
        numeric 3 printable 4 teletex 5 t61 5 videotex 6 ia5 7 graphic 8
        visible 9 iso646 9 general 10 universal 11 int4 11
        bmp 12 unicode 12 utf8 13
    } $encformat] $s]]
}

###
# Utility procs

proc twapi::_algid {class type alg} {
    return [expr {($class << 13) | ($type << 9) | $alg}]
}

proc twapi::_make_algorithm_identifier {oid {param {}}} {
    if {[string length $oid] == 0} {
        return ""
    }
    set oid [oid $oid]
    if {[string length $param]} {
        return [list $oid $param]
    } else {
        return [list $oid]
    }
}

twapi::proc* twapi::_cert_prop_id {prop} {
    # Certificate property menomics
    variable _cert_prop_name_id_map
    array set _cert_prop_name_id_map {
        key_prov_handle        1
        key_prov_info          2
        sha1_hash              3
        hash                   3
        md5_hash               4
        key_context            5
        key_spec               6
        ie30_reserved          7
        pubkey_hash_reserved   8
        enhkey_usage           9
        ctl_usage              9
        next_update_location   10
        friendly_name          11
        pvk_file               12
        description            13
        access_state           14
        signature_hash         15
        smart_card_data        16
        efs                    17
        fortezza_data          18
        archived               19
        key_identifier         20
        auto_enroll            21
        pubkey_alg_para        22
        cross_cert_dist_points 23
        issuer_public_key_md5_hash     24
        subject_public_key_md5_hash    25
        id             26
        date_stamp             27
        issuer_serial_number_md5_hash  28
        subject_name_md5_hash  29
        extended_error_info    30

        renewal                64
        archived_key_hash      65
        auto_enroll_retry      66
        aia_url_retrieved      67
        authority_info_access  68
        backed_up              69
        ocsp_response          70
        request_originator     71
        source_location        72
        source_url             73
        new_key                74
        ocsp_cache_prefix      75
        smart_card_root_info   76
        no_auto_expire_check   77
        ncrypt_key_handle      78
        hcryptprov_or_ncrypt_key_handle   79

        subject_info_access    80
        ca_ocsp_authority_info_access  81
        ca_disable_crl         82
        root_program_cert_policies    83
        root_program_name_constraints 84
        subject_ocsp_authority_info_access  85
        subject_disable_crl    86
        cep                    87

        sign_hash_cng_alg      89

        scard_pin_id           90
        scard_pin_info         91
    }
} {
    variable _cert_prop_name_id_map

    if {[string is integer -strict $prop]} {
        return $prop
    }
    if {![info exists _cert_prop_name_id_map($prop)]} {
        badargs! "Unknown certificate property id '$prop'" 3
    }

    return $_cert_prop_name_id_map($prop)
}

twapi::proc* twapi::_cert_prop_name {id} {
    variable _cert_prop_name_id_map
    variable _cert_prop_id_name_map

    _cert_prop_id key_prov_handle; # Just to init _cert_prop_name_id_map
    array set _cert_prop_id_name_map [swapl [array get _cert_prop_name_id_map]]
} {
    variable _cert_prop_id_name_map
    if {[info exists _cert_prop_id_name_map($id)]} {
        return $_cert_prop_id_name_map($id)
    }
    if {[string is integer -strict $id]} {
        return $id
    }
    badargs! "Unknown certificate property id '$id'" 3
}

twapi::proc* twapi::_system_store_id {name} {
    variable _system_store_locations
    
    set _system_store_locations {
        service          0x40000
        ""               0x10000
        user             0x10000
        usergrouppolicy  0x70000
        localmachine     0x20000
        localmachineenterprise  0x90000
        localmachinegrouppolicy 0x80000
        services 0x50000
        users    0x60000
    }

    foreach loc [CertEnumSystemStoreLocation 0] {
        dict set _system_store_locations {*}$loc
    }
} {
    variable _system_store_locations

    if {[string is integer -strict $name]} {
        if {$name < 65536} {
            badargs! "Invalid system store name $name" 3
        }
        return $name
    }

    return [dict! $_system_store_locations $name 2]
}

twapi::proc* twapi::_csp_type_name_to_id prov {
    variable _csp_name_id_map

    array set _csp_name_id_map {
        prov_rsa_full           1
        prov_rsa_sig            2
        prov_dss                3
        prov_fortezza           4
        prov_ms_exchange        5
        prov_ssl                6
        prov_rsa_schannel       12
        prov_dss_dh             13
        prov_ec_ecdsa_sig       14
        prov_ec_ecnra_sig       15
        prov_ec_ecdsa_full      16
        prov_ec_ecnra_full      17
        prov_dh_schannel        18
        prov_spyrus_lynks       20
        prov_rng                21
        prov_intel_sec          22
        prov_replace_owf        23
        prov_rsa_aes            24
    }
} {
    variable _csp_name_id_map

    set key [string tolower $prov]

    if {[info exists _csp_name_id_map($key)]} {
        return $_csp_name_id_map($key)
    }

    if {[string is integer -strict $prov]} {
        return $prov
    }

    badargs! "Invalid or unknown provider name '$prov'" 3
}

twapi::proc* twapi::_csp_type_id_to_name prov {
    variable _csp_name_id_map
    variable _csp_id_name_map

    _csp_type_name_to_id prov_rsa_full; # Just to ensure _csp_name_id_map exists
    array set _csp_id_name_map [swapl [array get _csp_name_id_map]]
} {
    variable _csp_id_name_map
    if {[info exists _csp_id_name_map($prov)]} {
        return $_csp_id_name_map($prov)
    }

    if {[string is integer -strict $prov]} {
        return $prov
    }

    badargs! "Invalid or unknown provider id '$prov'" 3
}

twapi::proc* twapi::oid {name} {
    variable _name_oid_map
    if {![info exists _name_oid_map]} {
        oids;                       # To init the map
    }
} {
    variable _name_oid_map

    if {[info exists _name_oid_map($name)]} {
        return $_name_oid_map($name)
    }
    if {[regexp {^\d([\d\.]*\d)?$} $name]} {
        return $name
    } else {
        badargs! "Invalid OID '$name'"
    }

}

twapi::proc* twapi::oidname {oid} {
    variable _oid_name_map
    if {![info exists _oid_name_map]} {
        oids;                       # To init the map
    }
} {
    variable _oid_name_map

    if {[info exists _oid_name_map($oid)]} {
        return $_oid_name_map($oid)
    }
    if {[regexp {^\d([\d\.]*\d)?$} $oid]} {
        return $oid
    } else {
        badargs! "Invalid OID '$name'"
    }
}




twapi::proc* twapi::oids {{pattern *}} {
    variable _oid_name_map
    variable _name_oid_map

    # TBD - clean up table for rarely used OIDs
    array set _name_oid_map {
        oid_common_name                   "2.5.4.3"
        oid_sur_name                      "2.5.4.4"
        oid_device_serial_number          "2.5.4.5"
        oid_country_name                  "2.5.4.6"
        oid_locality_name                 "2.5.4.7"
        oid_state_or_province_name        "2.5.4.8"
        oid_street_address                "2.5.4.9"
        oid_organization_name             "2.5.4.10"
        oid_organizational_unit_name      "2.5.4.11"
        oid_title                         "2.5.4.12"
        oid_description                   "2.5.4.13"
        oid_search_guide                  "2.5.4.14"
        oid_business_category             "2.5.4.15"
        oid_postal_address                "2.5.4.16"
        oid_postal_code                   "2.5.4.17"
        oid_post_office_box               "2.5.4.18"
        oid_physical_delivery_office_name "2.5.4.19"
        oid_telephone_number              "2.5.4.20"
        oid_telex_number                  "2.5.4.21"
        oid_teletext_terminal_identifier  "2.5.4.22"
        oid_facsimile_telephone_number    "2.5.4.23"
        oid_x21_address                   "2.5.4.24"
        oid_international_isdn_number     "2.5.4.25"
        oid_registered_address            "2.5.4.26"
        oid_destination_indicator         "2.5.4.27"
        oid_user_password                 "2.5.4.35"
        oid_user_certificate              "2.5.4.36"
        oid_ca_certificate                "2.5.4.37"
        oid_authority_revocation_list     "2.5.4.38"
        oid_certificate_revocation_list   "2.5.4.39"
        oid_cross_certificate_pair        "2.5.4.40"

        oid_rsa               "1.2.840.113549"
        oid_pkcs              "1.2.840.113549.1"
        oid_rsa_hash          "1.2.840.113549.2"
        oid_rsa_encrypt       "1.2.840.113549.3"

        oid_pkcs_1            "1.2.840.113549.1.1"
        oid_pkcs_2            "1.2.840.113549.1.2"
        oid_pkcs_3            "1.2.840.113549.1.3"
        oid_pkcs_4            "1.2.840.113549.1.4"
        oid_pkcs_5            "1.2.840.113549.1.5"
        oid_pkcs_6            "1.2.840.113549.1.6"
        oid_pkcs_7            "1.2.840.113549.1.7"
        oid_pkcs_8            "1.2.840.113549.1.8"
        oid_pkcs_9            "1.2.840.113549.1.9"
        oid_pkcs_10           "1.2.840.113549.1.10"
        oid_pkcs_12           "1.2.840.113549.1.12"

        oid_rsa_rsa           "1.2.840.113549.1.1.1"
        oid_rsa_md2rsa        "1.2.840.113549.1.1.2"
        oid_rsa_md4rsa        "1.2.840.113549.1.1.3"
        oid_rsa_md5rsa        "1.2.840.113549.1.1.4"
        oid_rsa_sha1rsa       "1.2.840.113549.1.1.5"
        oid_rsa_setoaep_rsa   "1.2.840.113549.1.1.6"

        oid_rsa_dh            "1.2.840.113549.1.3.1"

        oid_rsa_data          "1.2.840.113549.1.7.1"
        oid_rsa_signeddata    "1.2.840.113549.1.7.2"
        oid_rsa_envelopeddata "1.2.840.113549.1.7.3"
        oid_rsa_signenvdata   "1.2.840.113549.1.7.4"
        oid_rsa_digesteddata  "1.2.840.113549.1.7.5"
        oid_rsa_hasheddata    "1.2.840.113549.1.7.5"
        oid_rsa_encrypteddata "1.2.840.113549.1.7.6"

        oid_rsa_emailaddr     "1.2.840.113549.1.9.1"
        oid_rsa_unstructname  "1.2.840.113549.1.9.2"
        oid_rsa_contenttype   "1.2.840.113549.1.9.3"
        oid_rsa_messagedigest "1.2.840.113549.1.9.4"
        oid_rsa_signingtime   "1.2.840.113549.1.9.5"
        oid_rsa_countersign   "1.2.840.113549.1.9.6"
        oid_rsa_challengepwd  "1.2.840.113549.1.9.7"
        oid_rsa_unstructaddr  "1.2.840.113549.1.9.8"
        oid_rsa_extcertattrs  "1.2.840.113549.1.9.9"
        oid_rsa_certextensions "1.2.840.113549.1.9.14"
        oid_rsa_smimecapabilities "1.2.840.113549.1.9.15"
        oid_rsa_prefersigneddata "1.2.840.113549.1.9.15.1"

        oid_rsa_smimealg              "1.2.840.113549.1.9.16.3"
        oid_rsa_smimealgesdh          "1.2.840.113549.1.9.16.3.5"
        oid_rsa_smimealgcms3deswrap   "1.2.840.113549.1.9.16.3.6"
        oid_rsa_smimealgcmsrc2wrap    "1.2.840.113549.1.9.16.3.7"

        oid_rsa_md2           "1.2.840.113549.2.2"
        oid_rsa_md4           "1.2.840.113549.2.4"
        oid_rsa_md5           "1.2.840.113549.2.5"

        oid_rsa_rc2cbc        "1.2.840.113549.3.2"
        oid_rsa_rc4           "1.2.840.113549.3.4"
        oid_rsa_des_ede3_cbc  "1.2.840.113549.3.7"
        oid_rsa_rc5_cbcpad    "1.2.840.113549.3.9"


        oid_ansi_x942         "1.2.840.10046"
        oid_ansi_x942_dh      "1.2.840.10046.2.1"

        oid_x957              "1.2.840.10040"
        oid_x957_dsa          "1.2.840.10040.4.1"
        oid_x957_sha1dsa      "1.2.840.10040.4.3"

        oid_ds                "2.5"
        oid_dsalg             "2.5.8"
        oid_dsalg_crpt        "2.5.8.1"
        oid_dsalg_hash        "2.5.8.2"
        oid_dsalg_sign        "2.5.8.3"
        oid_dsalg_rsa         "2.5.8.1.1"

        oid_pkix_kp_server_auth "1.3.6.1.5.5.7.3.1"
        oid_pkix_kp_client_auth "1.3.6.1.5.5.7.3.2"
        oid_pkix_kp_code_signing   "1.3.6.1.5.5.7.3.3"
        oid_pkix_kp_email_protection      "1.3.6.1.5.5.7.3.4"
        oid_pkix_kp_ipsec_end_system "1.3.6.1.5.5.7.3.5"
        oid_pkix_kp_ipsec_tunnel "1.3.6.1.5.5.7.3.6"
        oid_pkix_kp_ipsec_user "1.3.6.1.5.5.7.3.7"
        oid_pkix_kp_timestamp_signing "1.3.6.1.5.5.7.3.8"
        oid_pkix_kp_ocsp_signing      "1.3.6.1.5.5.7.3.9"

        oid_oiw               "1.3.14"

        oid_oiwsec            "1.3.14.3.2"
        oid_oiwsec_md4rsa     "1.3.14.3.2.2"
        oid_oiwsec_md5rsa     "1.3.14.3.2.3"
        oid_oiwsec_md4rsa2    "1.3.14.3.2.4"
        oid_oiwsec_desecb     "1.3.14.3.2.6"
        oid_oiwsec_descbc     "1.3.14.3.2.7"
        oid_oiwsec_desofb     "1.3.14.3.2.8"
        oid_oiwsec_descfb     "1.3.14.3.2.9"
        oid_oiwsec_desmac     "1.3.14.3.2.10"
        oid_oiwsec_rsasign    "1.3.14.3.2.11"
        oid_oiwsec_dsa        "1.3.14.3.2.12"
        oid_oiwsec_shadsa     "1.3.14.3.2.13"
        oid_oiwsec_mdc2rsa    "1.3.14.3.2.14"
        oid_oiwsec_sharsa     "1.3.14.3.2.15"
        oid_oiwsec_dhcommmod  "1.3.14.3.2.16"
        oid_oiwsec_desede     "1.3.14.3.2.17"
        oid_oiwsec_sha        "1.3.14.3.2.18"
        oid_oiwsec_mdc2       "1.3.14.3.2.19"
        oid_oiwsec_dsacomm    "1.3.14.3.2.20"
        oid_oiwsec_dsacommsha "1.3.14.3.2.21"
        oid_oiwsec_rsaxchg    "1.3.14.3.2.22"
        oid_oiwsec_keyhashseal "1.3.14.3.2.23"
        oid_oiwsec_md2rsasign "1.3.14.3.2.24"
        oid_oiwsec_md5rsasign "1.3.14.3.2.25"
        oid_oiwsec_sha1       "1.3.14.3.2.26"
        oid_oiwsec_dsasha1    "1.3.14.3.2.27"
        oid_oiwsec_dsacommsha1 "1.3.14.3.2.28"
        oid_oiwsec_sha1rsasign "1.3.14.3.2.29"

        oid_oiwdir            "1.3.14.7.2"
        oid_oiwdir_crpt       "1.3.14.7.2.1"
        oid_oiwdir_hash       "1.3.14.7.2.2"
        oid_oiwdir_sign       "1.3.14.7.2.3"
        oid_oiwdir_md2        "1.3.14.7.2.2.1"
        oid_oiwdir_md2rsa     "1.3.14.7.2.3.1"

        oid_infosec                       "2.16.840.1.101.2.1"
        oid_infosec_sdnssignature         "2.16.840.1.101.2.1.1.1"
        oid_infosec_mosaicsignature       "2.16.840.1.101.2.1.1.2"
        oid_infosec_sdnsconfidentiality   "2.16.840.1.101.2.1.1.3"
        oid_infosec_mosaicconfidentiality "2.16.840.1.101.2.1.1.4"
        oid_infosec_sdnsintegrity         "2.16.840.1.101.2.1.1.5"
        oid_infosec_mosaicintegrity       "2.16.840.1.101.2.1.1.6"
        oid_infosec_sdnstokenprotection   "2.16.840.1.101.2.1.1.7"
        oid_infosec_mosaictokenprotection "2.16.840.1.101.2.1.1.8"
        oid_infosec_sdnskeymanagement     "2.16.840.1.101.2.1.1.9"
        oid_infosec_mosaickeymanagement   "2.16.840.1.101.2.1.1.10"
        oid_infosec_sdnskmandsig          "2.16.840.1.101.2.1.1.11"
        oid_infosec_mosaickmandsig        "2.16.840.1.101.2.1.1.12"
        oid_infosec_suiteasignature       "2.16.840.1.101.2.1.1.13"
        oid_infosec_suiteaconfidentiality "2.16.840.1.101.2.1.1.14"
        oid_infosec_suiteaintegrity       "2.16.840.1.101.2.1.1.15"
        oid_infosec_suiteatokenprotection "2.16.840.1.101.2.1.1.16"
        oid_infosec_suiteakeymanagement   "2.16.840.1.101.2.1.1.17"
        oid_infosec_suiteakmandsig        "2.16.840.1.101.2.1.1.18"
        oid_infosec_mosaicupdatedsig      "2.16.840.1.101.2.1.1.19"
        oid_infosec_mosaickmandupdsig     "2.16.840.1.101.2.1.1.20"
        oid_infosec_mosaicupdatedinteg    "2.16.840.1.101.2.1.1.21"
    }

    # OIDs for certificate extensions
    array set _name_oid_map {
        oid_authority_key_identifier_old  "2.5.29.1"
        oid_key_attributes            "2.5.29.2"
        oid_cert_policies_95          "2.5.29.3"
        oid_key_usage_restriction     "2.5.29.4"
        oid_subject_alt_name_old          "2.5.29.7"
        oid_issuer_alt_name_old           "2.5.29.8"
        oid_basic_constraints_old     "2.5.29.10"
        oid_key_usage                 "2.5.29.15"
        oid_privatekey_usage_period   "2.5.29.16"
        oid_basic_constraints        "2.5.29.19"

        oid_cert_policies             "2.5.29.32"
        oid_any_cert_policy           "2.5.29.32.0"
        oid_inhibit_any_policy        "2.5.29.54"

        oid_authority_key_identifier "2.5.29.35"
        oid_subject_key_identifier    "2.5.29.14"
        oid_subject_alt_name2         "2.5.29.17"
        oid_issuer_alt_name          "2.5.29.18"
        oid_crl_reason_code           "2.5.29.21"
        oid_reason_code_hold          "2.5.29.23"
        oid_crl_dist_points           "2.5.29.31"
        oid_enhanced_key_usage        "2.5.29.37"

        oid_any_enhanced_key_usage    "2.5.29.37.0"

        oid_crl_number                "2.5.29.20"
        oid_delta_crl_indicator       "2.5.29.27"
        oid_issuing_dist_point        "2.5.29.28"
        oid_freshest_crl              "2.5.29.46"
        oid_name_constraints          "2.5.29.30"

        oid_policy_mappings           "2.5.29.33"
        oid_legacy_policy_mappings    "2.5.29.5"
        oid_policy_constraints        "2.5.29.36"
    }

    array set _oid_name_map [swapl [array get _name_oid_map]]
} {
    variable _name_oid_map
    return [array get _name_oid_map $pattern]
}


proc twapi::_make_altnames_ext {altnames {critical 0} {issuer 0}} {
    set names {}
    foreach pair $altnames {
        lassign $pair alttype altname
        lappend names [list \
                           [dict get {
                               other 1
                               email 2
                               dns   3
                               directory 5
                               url 7
                               ip  8
                               registered 9
                           } $alttype] $altname]
    }

    return [list [expr {$issuer ? "2.5.29.18" : "2.5.29.17"}] $critical $names]
}

proc twapi::_get_enhkey_usage_oids {names} {
    array set map [oids oid_pkix_kp_*]

    # We use an array to remove duplicates
    array set oids {}
    foreach name $names {
        if {[info exists map($name)]} {
            set oids($map($name)) 1
        } elseif {[info exists map(oid_pkix_kp_$name)]} {
            set oids($map(oid_pkix_kp_$name)) 1
        } elseif {[regexp {^\d([\d\.]*\d)?$} $name]} {
            # Any OID will do
            set oids($name) 1
        } else {
            error "Invalid Enhanced Key Usage OID \"$name\""
        }
    }
    return [array names oids]
}

proc twapi::_make_enhkeyusage_ext {enhkeyusage {critical 0}} {
    return [list "2.5.29.37" $critical [_get_enhkey_usage_oids $enhkeyusage]]
}

twapi::proc* twapi::_init_keyusage_names {} {
    variable _keyusage_byte1
    variable _keyusage_byte2
    set _keyusage_byte1 {
        digital_signature     0x80
        non_repudiation       0x40
        key_encipherment      0x20
        data_encipherment     0x10
        key_agreement         0x08
        key_cert_sign         0x04
        crl_sign              0x02
        encipher_only         0x01
    }
    set _keyusage_byte2 {
        decipher_only         0x80
    }
} {}

proc twapi::_make_basic_constraints_ext {basicconstraints {critical 1}} {
    lassign $basicconstraints isca capathlenvalid capathlen
    if {[string is boolean $isca] && [string is boolean $capathlenvalid] &&
        [string is integer -strict $capathlen] && $capathlen >= 0} {
        return [list "2.5.29.19" $critical [list $isca $capathlenvalid $capathlen]]
    }
    error "Invalid basicconstraints value"
}

proc twapi::_make_keyusage_ext {keyusage {critical 0}} {
    variable _keyusage_byte1
    variable _keyusage_byte2

    _init_keyusage_names
    set byte1 0
    set byte2 0
    foreach usage $keyusage {
        if {[dict exists $_keyusage_byte1 $usage]} {
            set byte1 [expr {$byte1 | [dict get $_keyusage_byte1 $usage]}]
        } elseif {[dict exists $_keyusage_byte2 $usage]} {
            set byte2 [expr {$byte2 | [dict get $_keyusage_byte2 $usage]}]
        } else {
            error "Invalid key usage value \"$keyusage\""
        }
    }

    set bin [binary format cc $byte1 $byte2]
    # 7 -> # unused bits in last byte
    return [list "2.5.29.15" $critical [list $bin 7]]
}

# Given a byte array, decode to key usage flags
proc twapi::_cert_decode_keyusage {bin} {
    variable _keyusage_byte1
    variable _keyusage_byte2
    
    _init_keyusage_names

    binary scan $bin c* bytes

    if {[llength $bytes] == 0} {
        return *;               # Field not present, TBD
    }

    set usages {}
    set byte [lindex $bytes 0]
    dict for {key val} $_keyusage_byte1 {
        if {$byte & $val} {
            lappend usages $key
        }
    } 

    set byte [lindex $bytes 1]
    dict for {key val} $_keyusage_byte2 {
        if {$byte & $val} {
            lappend usages $key
            set byte [expr {$byte & ~$val}]
        }
    } 

    if {0} {
        # Commented out because some certificates seem to contain
        # bits not defined by RF5280. Do not barf on these

        # For the second byte, not all bits are defined. Error if any
        # that we do not understand
        if {$byte} {
            error "Key usage sequence $bytes includes unsupported bits"
        }

        # If there are more bytes, they should all be 0 as well
        foreach byte [lrange $bytes 2 end] {
            if {$byte} {
                error "Key usage sequence $bytes includes unsupported bits"
            }
        }
    }

    return $usages
}

proc twapi::_cert_decode_enhkey {vals} {
    set result {}
    set symmap [swapl [oids oid_pkix_kp_*]]
    foreach val $vals {
        if {[dict exists $symmap $val]} {
            lappend result [string range [dict get $symmap $val] 12 end]
        } else {
            lappend result $val
        }
    }
    return $result
}

proc twapi::_cert_decode_extension {oid val} {
    # TBD - see what other types need to be decoded
    # 2.5.29.19 - basic constraints
    # 
    switch $oid {
        2.5.29.15 { return [_cert_decode_keyusage $val] }
        2.5.29.37 { return [_cert_decode_enhkey $val] }
        2.5.29.17 -
        2.5.29.18 {
            set names {}
            foreach elem $val {
                lappend names [list [dict* {
                    1 other 2 email 3 dns 5 directory 7 url 8 ip 9 registered
                } [lindex $elem 0]] [lindex $elem 1]]
            }
            return $names
        }
    }
    return $val
}

proc twapi::_crypt_keyspec {keyspec} {
    return [dict* {keyexchange 1 signature 2} $keyspec]
}

proc twapi::_cert_create_parse_options {optvals optsvar} {
    upvar 1 $optsvar opts

    # TBD - add -issueraltnames
    parseargs optvals {
        start.arg
        end.arg
        serialnumber.arg
        altnames.arg
        enhkeyusage.arg
        keyusage.arg
        basicconstraints.arg
        {purpose.arg {}}
        {capathlen.int -1}
    } -ignoreunknown -setvars

    set ca [expr {"ca" in $purpose}]
    if {$ca} {
        if {[info exists basicconstraints]} {
            badargs! "Option -basicconstraints cannot be specified if \"ca\" is included in the -purpose option"
        }
        if {$capathlen < 0} {
            set basicconstraints {{1 0 0} 1};  # No path length constraint
        } else {
            set basicconstraints [list [list 1 1 $capathlen] 1]
        }
    } else {
        if {![info exists basicconstraints]} {
            set basicconstraints {{0 0 0} 1}
        }
    }
    set sslserver [expr {"server" in $purpose}]
    set sslclient [expr {"client" in $purpose}]

    if {[info exists serialnumber]} {
        if {$serialnumber <= 0 || $serialnumber > 0x7fffffffffffffff} {
            badargs! "Serial number must be specified as a positive wide integer."
        }
        # Format as little endian
        set opts(serialnumber) [binary format w $serialnumber]
    } else {
        # Generate 15 byte random and add high byte (little endian)
        # to 0x01 to ensure it is treated as positive
        set opts(serialnumber) "[random_bytes 15]\x01"
    }
    
    # Validity period
    if {[info exists start]} {
        set opts(start) $start
    } else {
        set opts(start) [_seconds_to_timelist [clock seconds] 1]
    }
    if {[info exists end]} {
        set opts(end) $end
    } else {
        set opts(end) $opts(start)
        lset opts(end) 0 [expr {[lindex $opts(end) 0] + 1}]
        # Ensure valid date (Feb 29 leap year -> non-leap year for example)
        set opts(end) [clock format [clock scan [lrange $opts(end) 0 2] -format "%Y %N %e"] -format "%Y %N %e"]
        lappend opts(end) 23 59 59 0
    }

    # Generate the extensions list
    set exts {}
    lappend exts [_make_basic_constraints_ext {*}$basicconstraints ]
    if {$ca} {
        lappend extra_keyusage key_cert_sign crl_sign
    }
    if {$sslserver || $sslclient} {
        lappend extra_keyusage digital_signature key_encipherment key_agreement
        if {$sslserver} { 
           lappend extra_enhkeyusage oid_pkix_kp_server_auth
        }
        if {$sslclient} {
            lappend extra_enhkeyusage oid_pkix_kp_client_auth
        }
    }

    if {[info exists extra_keyusage]} {
        if {[info exists keyusage]} {
            # TBD - should it be marked critical or not ?
            lset keyusage 0 [concat [lindex $keyusage 0] $extra_keyusage]
        } else {
            # TBD - should it be marked critical or not ?
            set keyusage [list $extra_keyusage 1]
        }
    }

    if {[info exists keyusage]} {
        lappend exts [_make_keyusage_ext {*}$keyusage]
    }

    if {[info exists extra_enhkeyusage]} {
        if {[info exists enhkeyusage]} {
            # TBD - should it be marked critical or not ?
            lset enhkeyusage 0 [concat [lindex $enhkeyusage 0] $extra_enhkeyusage]
        } else {
            # TBD - should it be marked critical or not ?
            set enhkeyusage [list $extra_enhkeyusage 1]
        }
    }
    if {[info exists enhkeyusage]} {
        lappend exts [_make_enhkeyusage_ext {*}$enhkeyusage]
    }

    if {[info exists altnames]} {
        lappend exts [_make_altnames_ext {*}$altnames]
    }

    set opts(extensions) $exts

    return $optvals
}

proc twapi::_cert_add_parseargs {vargs} {
    upvar 1 $vargs optvals
    parseargs optvals {
        {disposition.arg preserve {overwrite duplicate update preserve}}
    } -maxleftover 0 -setvars

    # 4 -> CERT_STORE_ADD_ALWAYS
    # 3 -> CERT_STORE_ADD_REPLACE_EXISTING
    # 6 -> CERT_STORE_ADD_NEWER
    # 1 -> CERT_STORE_ADD_NEW

    return [list disposition \
                [dict get {
                    duplicate 4
                    overwrite 3
                    update 6
                    preserve 1
                } $disposition]]
}

proc twapi::_parse_store_open_opts {optvals} {
    array set opts [parseargs optvals  {
        {commitenable.bool    0 0x00010000}
        {readonly.bool        0 0x00008000}
        {existing.bool        0 0x00004000}
        {create.bool          0 0x00002000}
        {includearchived.bool 0 0x00000200}
        {maxpermissions.bool  0 0x00001000}
        {deferclose.bool      0 0x00000004}
        {backupprivilege.bool 0 0x00000800}
    } -maxleftover 0 -nulldefault]

    set flags 0
    foreach {opt val} [array get opts] {
        incr flags $val
    }
    return $flags
}


# Utility proc to generate certs in a memory store - 
# one self signed which is used to sign a client and a server cert
proc twapi::make_test_certs {{hstore {}} args} {
    crypt_test_container_cleanup

    parseargs args {
        {csp.arg {Microsoft Strong Cryptographic Provider}}
        {csptype.arg prov_rsa_full}
        unique
        {duration.int 5}
    } -maxleftover 0 -setvars

    set enddate [clock format [clock seconds] -format "%Y %N %e"]
    lset enddate 0 [expr {[lindex $enddate 0]+$duration}]
    # Ensure valid date e.g. Feb 29 non-leap year
    set enddate [clock format [clock scan $enddate -format "%Y %N %e"] -format "%Y %N %e"]

    if {$unique} {
        set uuid [twapi::new_uuid]
    } else {
        set uuid ""
    }

    # Create the self signed CA cert
    set container twapitestca$uuid
    set crypt [twapi::crypt_acquire $container -csp $csp -csptype $csptype -create 1]
    twapi::crypt_key_free [twapi::crypt_key_generate $crypt signature -exportable 1]
    set ca_altnames [list [list [list email ${container}@twapitest.com] [list dns ${container}.twapitest.com] [list url http://${container}.twapitest.com] [list directory [cert_name_to_blob "CN=${container}altname"]] [list ip [binary format c4 {127 0 0 2}]]]]
    set cert [twapi::cert_create_self_signed_from_crypt_context "CN=$container, C=IN, O=Tcl, OU=twapi" $crypt -purpose {ca} -altnames $ca_altnames -end $enddate]
    if {[llength $hstore] == 0} {
        set hstore [twapi::cert_temporary_store]
    }
    set ca_certificate [twapi::cert_store_add_certificate $hstore $cert]
    twapi::cert_release $cert
    twapi::cert_set_key_prov $ca_certificate -csp $csp -keycontainer $container -csptype $csptype
    crypt_free $crypt

    # Create the client and server certs
    foreach cert_type {intermediate server client altserver full min} {
        set container twapitest${cert_type}$uuid
        set subject $container
        set crypt [twapi::crypt_acquire $container -csp $csp -csptype $csptype -create 1]
        twapi::crypt_key_free [twapi::crypt_key_generate $crypt keyexchange -exportable 1]
        switch $cert_type {
            intermediate {
                set req [cert_request_create "CN=$container, C=IN, O=Tcl, OU=twapi" $crypt keyexchange -purpose ca]
                set signing_cert $ca_certificate
            }
            altserver {
                # No COMMON name. Used for testing use of DNS altname
                set altnames [list [list [list dns ${cert_type}.twapitest.com] [list dns ${cert_type}2.twapitest.com]]]
                set req [cert_request_create "C=IN, O=Tcl, OU=twapi, OU=$container" $crypt keyexchange -purpose $cert_type -altnames $altnames]
                set signing_cert $ca_certificate
            }
            client -
            server {
                set req [cert_request_create "CN=$container, C=IN, O=Tcl, OU=twapi" $crypt keyexchange -purpose $cert_type]
                set signing_cert $intermediate_certificate
            }
            full {
                set altnames [list [list [list email ${container}@twapitest.com] [list dns ${cert_type}.twapitest.com] [list url http://${container}.twapitest.com] [list directory [cert_name_to_blob "CN=${container}altname"]] [list ip [binary format c4 {127 0 0 1}]]]]
                set req [cert_request_create \
                             "CN=$container, C=IN, O=Tcl, OU=twapi" \
                             $crypt keyexchange \
                             -keyusage [list {crl_sign data_encipherment digital_signature key_agreement key_cert_sign key_encipherment non_repudiation} 1]\
                             -enhkeyusage [list {client_auth code_signing email_protection ipsec_end_system  ipsec_tunnel ipsec_user server_auth timestamp_signing ocsp_signing} 1] \
                             -altnames $altnames]
                set signing_cert $ca_certificate
            }
            min {
                set req [cert_request_create "CN=$container" $crypt keyexchange]
                set signing_cert $ca_certificate
            }
        }
        crypt_free $crypt
        set parsed_req [cert_request_parse $req]
        set subject [dict get $parsed_req subject]
        set pubkey [dict get $parsed_req pubkey]
        set opts {}
        foreach optname {-basicconstraints -keyusage -enhkeyusage -altnames} {
            if {[dict exists $parsed_req extensions $optname]} {
                lappend opts $optname [dict get $parsed_req extensions $optname]
            }
        }
        set encoded_cert [cert_create $subject $pubkey $signing_cert {*}$opts -end $enddate]
        set certificate [twapi::cert_store_add_encoded_certificate $hstore $encoded_cert]
        twapi::cert_set_key_prov $certificate -csp $csp -keycontainer $container -csptype $csptype -keyspec keyexchange
        if {$cert_type eq "intermediate"} {
            set intermediate_certificate $certificate
        } else {
            cert_release $certificate
        }
    }

    cert_release $ca_certificate
    cert_release $intermediate_certificate
    return $hstore
}

proc twapi::dump_test_certs {hstore dir {pfxfile twapitest.pfx}} {
    set fd [open [file join $dir $pfxfile] wb]
    puts -nonewline $fd [cert_store_export_pfx $hstore "" -exportprivatekeys 1]
    close $fd
    cert_store_iterate $hstore c {
        set fd [open [file join $dir [cert_subject_name $c -name simpledisplay].cer] wb]
        puts -nonewline $fd [cert_export $c]
        close $fd
    }
}

proc twapi::crypt_test_containers {} {
    set crypt [crypt_acquire "" -verifycontext 1]
    twapi::trap {
        set names {}
        foreach name [crypt_key_container_names $crypt] {
            if {[string match -nocase twapitest* $name]} {
                lappend names $name
            }
        }
    } finally {
        crypt_free $crypt
    }
    return $names
}

proc twapi::crypt_test_container_cleanup {} {
    foreach c [crypt_test_containers] {
        crypt_key_container_delete $c
    }
}


# If we are being sourced ourselves, then we need to source the remaining files.
if {[file tail [info script]] eq "crypto.tcl"} {
    source [file join [file dirname [info script]] sspi.tcl]
    source [file join [file dirname [info script]] tls.tcl]
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<






























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/device.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
#
# Copyright (c) 2008-2014 Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

namespace eval twapi {
    struct _PREVENT_MEDIA_REMOVAL {
            BOOLEAN PreventMediaRemoval;
    }
    record device_element { class_guid device_instance reserved }
}

interp alias {} close_devinfoset {} devinfoset_close

proc twapi::rescan_devices {} {
    CM_Reenumerate_DevNode_Ex [CM_Locate_DevNode_Ex "" 0] 0
}


# Callback invoked for device changes.
# Does some processing of passed data and then invokes the
# real callback script
proc twapi::_device_notification_handler {id args} {
    variable _device_notifiers
    set idstr "devnotifier#$id"
    if {![info exists _device_notifiers($idstr)]} {
        # Notifications that expect a response default to "true"
        return 1
    }
    set script [lindex $_device_notifiers($idstr) 1]

    # For volume notifications, change drive bitmask to
    # list of drives before passing back to script
    set event [lindex $args 0]
    if {[lindex $args 1] eq "volume" &&
        ($event eq "deviceremovecomplete" || $event eq "devicearrival")} {
        lset args 2 [_drivemask_to_drivelist [lindex $args 2]]

        # Also indicate whether network volume and whether change is a media
        # change or physical change
        set attrs [list ]
        set flags [lindex $args 3]
        if {$flags & 1} {
            lappend attrs mediachange
        }
        if {$flags & 2} {
            lappend attrs networkvolume
        }
        lset args 3 $attrs
    }

    return [uplevel #0 [linsert $script end $idstr {*}$args]]
}

proc twapi::start_device_notifier {script args} {
    variable _device_notifiers

    set script [lrange $script 0 end]; # Verify syntactically a list

    array set opts [parseargs args {
        deviceinterface.arg
        handle.arg
    } -maxleftover 0]

    # For reference - some common device interface classes
    # NOTE: NOT ALL HAVE BEEN VERIFIED!
    # Network Card      {ad498944-762f-11d0-8dcb-00c04fc3358c}
    # Human Interface Device (HID)      {4d1e55b2-f16f-11cf-88cb-001111000030}
    # GUID_DEVINTERFACE_DISK          - {53f56307-b6bf-11d0-94f2-00a0c91efb8b}
    # GUID_DEVINTERFACE_CDROM         - {53f56308-b6bf-11d0-94f2-00a0c91efb8b}
    # GUID_DEVINTERFACE_PARTITION     - {53f5630a-b6bf-11d0-94f2-00a0c91efb8b}
    # GUID_DEVINTERFACE_TAPE          - {53f5630b-b6bf-11d0-94f2-00a0c91efb8b}
    # GUID_DEVINTERFACE_WRITEONCEDISK - {53f5630c-b6bf-11d0-94f2-00a0c91efb8b}
    # GUID_DEVINTERFACE_VOLUME        - {53f5630d-b6bf-11d0-94f2-00a0c91efb8b}
    # GUID_DEVINTERFACE_MEDIUMCHANGER - {53f56310-b6bf-11d0-94f2-00a0c91efb8b}
    # GUID_DEVINTERFACE_FLOPPY        - {53f56311-b6bf-11d0-94f2-00a0c91efb8b}
    # GUID_DEVINTERFACE_CDCHANGER     - {53f56312-b6bf-11d0-94f2-00a0c91efb8b}
    # GUID_DEVINTERFACE_STORAGEPORT   - {2accfe60-c130-11d2-b082-00a0c91efb8b}
    # GUID_DEVINTERFACE_KEYBOARD      - {884b96c3-56ef-11d1-bc8c-00a0c91405dd}
    # GUID_DEVINTERFACE_MOUSE         - {378de44c-56ef-11d1-bc8c-00a0c91405dd}
    # GUID_DEVINTERFACE_PARALLEL      - {97F76EF0-F883-11D0-AF1F-0000F800845C}
    # GUID_DEVINTERFACE_COMPORT       - {86e0d1e0-8089-11d0-9ce4-08003e301f73}
    # GUID_DEVINTERFACE_DISPLAY_ADAPTER - {5b45201d-f2f2-4f3b-85bb-30ff1f953599}
    # GUID_DEVINTERFACE_USB_HUB       - {f18a0e88-c30c-11d0-8815-00a0c906bed8}
    # GUID_DEVINTERFACE_USB_DEVICE    - {A5DCBF10-6530-11D2-901F-00C04FB951ED}
    # GUID_DEVINTERFACE_USB_HOST_CONTROLLER - {3abf6f2d-71c4-462a-8a92-1e6861e6af27}


    if {[info exists opts(deviceinterface)] && [info exists opts(handle)]} {
        error "Options -deviceinterface and -handle are mutually exclusive."
    }

    if {![info exists opts(deviceinterface)]} {
        set opts(deviceinterface) ""
    }
    if {[info exists opts(handle)]} {
        set type 6
    } else {
        set opts(handle) NULL
        switch -exact -- $opts(deviceinterface) {
            port            { set type 3 ; set opts(deviceinterface) "" }
            volume          { set type 2 ; set opts(deviceinterface) "" }
            default {
                # device interface class guid or empty string (for all device interfaces)
                set type 5
            }
        }
    }

    set id [Twapi_RegisterDeviceNotification $type $opts(deviceinterface) $opts(handle)]
    set idstr "devnotifier#$id"

    set _device_notifiers($idstr) [list $id $script]
    return $idstr
}

proc twapi::stop_device_notifier {idstr} {
    variable _device_notifiers

    if {![info exists _device_notifiers($idstr)]} {
        return;
    }

    Twapi_UnregisterDeviceNotification [lindex $_device_notifiers($idstr) 0]
    unset _device_notifiers($idstr)
}

proc twapi::devinfoset {args} {
    array set opts [parseargs args {
        {guid.arg ""}
        {classtype.arg setup {interface setup}}
        {presentonly.bool false 0x2}
        {currentprofileonly.bool false 0x8}
        {deviceinfoset.arg NULL}
        {hwin.int 0}
        {system.arg ""}
        {pnpenumerator.arg ""}
    } -maxleftover 0]

    # DIGCF_ALLCLASSES is bitmask 4
    set flags [expr {$opts(guid) eq "" ? 0x4 : 0}]
    if {$opts(classtype) eq "interface"} {
        if {$opts(pnpenumerator) ne ""} {
            error "The -pnpenumerator option cannot be used when -classtype interface is specified."
        }
        # DIGCF_DEVICEINTERFACE
        set flags [expr {$flags | 0x10}]
    }

    # DIGCF_PRESENT
    set flags [expr {$flags | $opts(presentonly)}]

    # DIGCF_PRESENT
    set flags [expr {$flags | $opts(currentprofileonly)}]

    return [SetupDiGetClassDevsEx \
                $opts(guid) \
                $opts(pnpenumerator) \
                $opts(hwin) \
                $flags \
                $opts(deviceinfoset) \
                $opts(system)]
}


# Given a device information set, returns the device elements within it
proc twapi::devinfoset_elements {hdevinfo} {
    set result [list ]
    set i 0
    trap {
        while {true} {
            lappend result [SetupDiEnumDeviceInfo $hdevinfo $i]
            incr i
        }
    } onerror {TWAPI_WIN32 0x103} {
        # Fine, Just means no more items
    } onerror {TWAPI_WIN32 0x80070103} {
        # Fine, Just means no more items (HRESULT version of above code)
    }

    return $result
}

# Given a device information set, returns the device elements within it
proc twapi::devinfoset_instance_ids {hdevinfo} {
    set result [list ]
    set i 0
    trap {
        while {true} {
            lappend result [device_element_instance_id $hdevinfo [SetupDiEnumDeviceInfo $hdevinfo $i]]
            incr i
        }
    } onerror {TWAPI_WIN32 0x103} {
        # Fine, Just means no more items
    } onerror {TWAPI_WIN32 0x80070103} {
        # Fine, Just means no more items (HRESULT version of above code)
    }

    return $result
}

# Returns a device instance element from a devinfoset
proc twapi::devinfoset_element {hdevinfo instance_id} {
    return [SetupDiOpenDeviceInfo $hdevinfo $instance_id 0 0]
}

# Get the registry property for a devinfoset element
proc twapi::devinfoset_element_registry_property {hdevinfo develem prop} {
    Twapi_SetupDiGetDeviceRegistryProperty $hdevinfo $develem [_device_registry_sym_to_code $prop]
}

# Given a device information set, returns a list of specified registry
# properties for all elements of the set
# args is list of properties to retrieve
proc twapi::devinfoset_registry_properties {hdevinfo args} {
    set result [list ]
    trap {
        # Keep looping until there is an error saying no more items
        set i 0
        while {true} {

            # First element is the DEVINFO_DATA element
            set devinfo_data [SetupDiEnumDeviceInfo $hdevinfo $i]
            set item [list -deviceelement $devinfo_data ]

            # Get all specified property values
            foreach prop $args {
                set intprop [_device_registry_sym_to_code $prop]
                trap {
                    lappend item $prop \
                        [list success \
                             [Twapi_SetupDiGetDeviceRegistryProperty \
                                  $hdevinfo $devinfo_data $intprop]]
                } onerror {} {
                    lappend item $prop [list fail [list [trapresult] $::errorCode]]
                }
            }
            lappend result $item

            incr i
        }
    } onerror {TWAPI_WIN32 0x103} {
        # Fine, Just means no more items
    } onerror {TWAPI_WIN32 0x80070103} {
        # Fine, Just means no more items (HRESULT version of above code)
    }

    return $result
}


# Given a device information set, returns specified device interface
# properties
# TBD - document ?
proc twapi::devinfoset_interface_details {hdevinfo guid args} {
    set result [list ]

    array set opts [parseargs args {
        {matchdeviceelement.arg {}}
        interfaceclass
        flags
        devicepath
        deviceelement
        ignoreerrors
    } -maxleftover 0]

    trap {
        # Keep looping until there is an error saying no more items
        set i 0
        while {true} {
            set interface_data [SetupDiEnumDeviceInterfaces $hdevinfo \
                                    $opts(matchdeviceelement) $guid $i]
            set item [list ]
            if {$opts(interfaceclass)} {
                lappend item -interfaceclass [lindex $interface_data 0]
            }
            if {$opts(flags)} {
                set flags    [lindex $interface_data 1]
                set symflags [_make_symbolic_bitmask $flags {active 1 default 2 removed 4} false]
                lappend item -flags [linsert $symflags 0 $flags]
            }

            if {$opts(devicepath) || $opts(deviceelement)} {
                # Need to get device interface detail.
                trap {
                    foreach {devicepath deviceelement} \
                        [SetupDiGetDeviceInterfaceDetail \
                             $hdevinfo \
                             $interface_data \
                             $opts(matchdeviceelement)] \
                        break

                    if {$opts(deviceelement)} {
                        lappend item -deviceelement $deviceelement
                    }
                    if {$opts(devicepath)} {
                        lappend item -devicepath $devicepath
                    }
                } onerror {} {
                    if {! $opts(ignoreerrors)} {
                        rethrow
                    }
                }
            }
            lappend result $item

            incr i
        }
    } onerror {TWAPI_WIN32 0x103} {
        # Fine, Just means no more items
    } onerror {TWAPI_WIN32 0x80070103} {
        # Fine, Just means no more items (HRESULT version of above code)
    }

    return $result
}


# Return the guids associated with a device class set name. Note
# the latter is not unique so multiple guids may be associated.
proc twapi::device_setup_class_name_to_guids {name args} {
    array set opts [parseargs args {
        system.arg
    } -maxleftover 0 -nulldefault]

    return [twapi::SetupDiClassGuidsFromNameEx $name $opts(system)]
}

# Utility functions

proc twapi::_init_device_registry_code_maps {} {
    variable _device_registry_syms
    variable _device_registry_codes

    # Note this list is ordered based on the corresponding integer codes
    set _device_registry_code_syms {
        devicedesc hardwareid compatibleids unused0 service unused1
        unused2 class classguid driver configflags mfg friendlyname
        location_information physical_device_object_name capabilities
        ui_number upperfilters lowerfilters
        bustypeguid legacybustype busnumber enumerator_name security
        security_sds devtype exclusive characteristics address
        ui_number_desc_format device_power_data
        removal_policy removal_policy_hw_default removal_policy_override
        install_state location_paths base_containerid
    }

    set i 0
    foreach sym $_device_registry_code_syms {
        set _device_registry_codes($sym) $i
        incr i
    }
}

# Map a device registry property to a symbol
proc twapi::_device_registry_code_to_sym {code} {
    _init_device_registry_code_maps

    # Once we have initialized, redefine ourselves so we do not do so
    # every time. Note define at global ::twapi scope!
    proc ::twapi::_device_registry_code_to_sym {code} {
        variable _device_registry_code_syms
        if {$code >= [llength $_device_registry_code_syms]} {
            return $code
        } else {
            return [lindex $_device_registry_code_syms $code]
        }
    }
    # Call the redefined proc
    return [_device_registry_code_to_sym $code]
}

# Map a device registry property symbol to a numeric code
proc twapi::_device_registry_sym_to_code {sym} {
    _init_device_registry_code_maps

    # Once we have initialized, redefine ourselves so we do not do so
    # every time. Note define at global ::twapi scope!
    proc ::twapi::_device_registry_sym_to_code {sym} {
        variable _device_registry_codes
        # Return the value. If non-existent, an error will be raised
        if {[info exists _device_registry_codes($sym)]} {
            return $_device_registry_codes($sym)
        } elseif {[string is integer -strict $sym]} {
            return $sym
        } else {
            error "Unknown or unsupported device registry property symbol '$sym'"
        }
    }
    # Call the redefined proc
    return [_device_registry_sym_to_code $sym]
}

# Do a device ioctl, returning result as a binary
# TBD - document that caller has to handle errors 122 (ERROR_INSUFFICIENT_BUFFER) and (ERROR_MORE_DATA)
proc twapi::device_ioctl {h code args} {
    array set opts [parseargs args {
        {input.arg {}}
        {outputcount.int 0}
    } -maxleftover 0]

    return [DeviceIoControl $h $code $opts(input) $opts(outputcount)]
}


# Return a list of physical disks. Note CD-ROMs and floppies not included
proc twapi::find_physical_disks {} {
    # Disk interface class guid
    set guid {{53F56307-B6BF-11D0-94F2-00A0C91EFB8B}}
    set hdevinfo [devinfoset \
                      -guid $guid \
                      -presentonly true \
                      -classtype interface]
    trap {
        return [kl_flatten [devinfoset_interface_details $hdevinfo $guid -devicepath] -devicepath]
    } finally {
        devinfoset_close $hdevinfo
    }
}

# Return information about a physical disk
proc twapi::get_physical_disk_info {disk args} {
    set result [list ]

    array set opts [parseargs args {
        geometry
        layout
        all
    } -maxleftover 0]

    if {$opts(all) || $opts(geometry) || $opts(layout)} {
        set h [create_file $disk -createdisposition open_existing]
    }

    trap {
        if {$opts(all) || $opts(geometry)} {
            # IOCTL_DISK_GET_DRIVE_GEOMETRY - 0x70000
            if {[binary scan [device_ioctl $h 0x70000 -outputcount 24] "wiiii" geom(-cylinders) geom(-mediatype) geom(-trackspercylinder) geom(-sectorspertrack) geom(-bytespersector)] != 5} {
                error "DeviceIoControl 0x70000 on disk '$disk' returned insufficient data."
            }
            lappend result -geometry [array get geom]
        }

        if {$opts(all) || $opts(layout)} {
            # XP and later - IOCTL_DISK_GET_DRIVE_LAYOUT_EX
            set data [device_ioctl $h 0x70050 -outputcount 624]
            if {[binary scan $data "i i" partstyle layout(-partitioncount)] != 2} {
                error "DeviceIoControl 0x70050 on disk '$disk' returned insufficient data."
            }
            set layout(-partitionstyle) [_partition_style_sym $partstyle]
            switch -exact -- $layout(-partitionstyle) {
                mbr {
                    if {[binary scan $data "@8 i" layout(-signature)] != 1} {
                        error "DeviceIoControl 0x70050 on disk '$disk' returned insufficient data."
                    }
                }
                gpt {
                    set pi(-diskid) [_binary_to_guid $data 32]
                    if {[binary scan $data "@8 w w i" layout(-startingusableoffset) layout(-usablelength) layout(-maxpartitioncount)] != 3} {
                        error "DeviceIoControl 0x70050 on disk '$disk' returned insufficient data."
                    }
                }
                raw -
                unknown {
                    # No fields to add
                }
            }

            set layout(-partitions) [list ]
            for {set i 0} {$i < $layout(-partitioncount)} {incr i} {
                # Decode each partition in turn. Sizeof of PARTITION_INFORMATION_EX is 144
                lappend layout(-partitions) [_decode_PARTITION_INFORMATION_EX_binary $data [expr {48 + (144*$i)}]]
            }
            lappend result -layout [array get layout]
        }

    } finally {
        if {[info exists h]} {
            CloseHandle $h
        }
    }

    return $result
}

# Given a Tcl binary and offset, decode the PARTITION_INFORMATION_EX record
proc twapi::_decode_PARTITION_INFORMATION_EX_binary {bin off} {
    if {[binary scan $bin "@$off i x4 w w i c" \
             pi(-partitionstyle) \
             pi(-startingoffset) \
             pi(-partitionlength) \
             pi(-partitionnumber) \
             pi(-rewritepartition)] != 5} {
        error "Truncated partition structure."
    }

    set pi(-partitionstyle) [_partition_style_sym $pi(-partitionstyle)]

    # MBR/GPT are at offset 32 in the structure
    switch -exact -- $pi(-partitionstyle) {
        mbr {
            if {[binary scan $bin "@$off x32 c c c x i" pi(-partitiontype) pi(-bootindicator) pi(-recognizedpartition) pi(-hiddensectors)] != 4} {
                error "Truncated partition structure."
            }
            # Show partition type in hex, not negative number
            set pi(-partitiontype) [format 0x%2.2x [expr {0xff & $pi(-partitiontype)}]]
        }
        gpt {
            set pi(-partitiontype) [_binary_to_guid $bin [expr {$off+32}]]
            set pi(-partitionif)   [_binary_to_guid $bin [expr {$off+48}]]
            if {[binary scan $bin "@$off x64 w" pi(-attributes)] != 1} {
                error "Truncated partition structure."
            }
            set pi(-name) [_ucs16_binary_to_string [string range $bin [expr {$off+72}] end]]
        }
        raw -
        unknown {
            # No fields to add
        }

    }

    return [array get pi]
}

#  IOCTL_STORAGE_EJECT_MEDIA
interp alias {} twapi::eject {} twapi::eject_media
proc twapi::eject_media device {
    # http://support.microsoft.com/default.aspx?scid=KB;EN-US;Q165721&
    set h [_open_disk_device $device]
    trap {
        device_ioctl $h 0x90018; # FSCTL_LOCK_VOLUME
        device_ioctl $h 0x90020; # FSCTL_DISMOUNT_VOLUME
        #  IOCTL_STORAGE_MEDIA_REMOVAL (0)
        device_ioctl $h 0x2d4804 -input [_PREVENT_MEDIA_REMOVAL 0]
        device_ioctl $h 0x2d4808; # IOCTL_STORAGE_EJECT_MEDIA
    } finally {
        close_handle $h
    }
}

# IOCTL_DISK_LOAD_MEDIA
# Note - should we use IOCTL_DISK_LOAD_MEDIA2 instead (0x2d080c) see
# SDK, faster if read / write access not necessary. We are closing
# the handle right away anyway but would that stop other apps from
# acessing the file system on the CD ? Need to try (note device
# has to be opened with FILE_READ_ATTRIBUTES only in that case)

interp alias {} twapi::load_media {} twapi::_issue_disk_ioctl 0x2d480c

#  FSCTL_LOCK_VOLUME
# TBD - interp alias {} twapi::lock_volume {} twapi::_issue_disk_ioctl 0x90018
#  FSCTL_LOCK_VOLUME
# TBD - interp alias {} twapi::unlock_volume {} twapi::_issue_disk_ioctl 0x9001c

proc twapi::_lock_media {lock device} {
    # IOCTL_STORAGE_MEDIA_REMOVAL
    _issue_disk_ioctl 0x2d4804 $device -input [_PREVENT_MEDIA_REMOVAL $lock]
}
interp alias {} twapi::lock_media {} twapi::_lock_media 1
interp alias {} twapi::unlock_media {} twapi::_lock_media 0

proc twapi::_issue_disk_ioctl {ioctl device args} {
    set h [_open_disk_device $device]
    trap {
        device_ioctl $h $ioctl {*}$args
    } finally {
        close_handle $h
    }
}

twapi::proc* twapi::_open_disk_device {device} {
    package require twapi_storage
} {
    # device must be "cdrom", X:, X:\\, X:/, a volume or a physical disk as 
    # returned from find_physical_disks
    switch -regexp -nocase -- $device {
        {^cdrom$} {
            foreach drive [find_logical_drives] {
                if {![catch {get_drive_type $drive} drive_type]} {
                    if {$drive_type eq "cdrom"} {
                        set device "\\\\.\\$drive"
                        break
                    }
                }
            }
            if {$device eq "cdrom"} {
                error "Could not find a CD-ROM device."
            }
        }
        {^[[:alpha:]]:(/|\\)?$} { 
            set device "\\\\.\\[string range $device 0 1]"
        }
        {^\\\\\?\\.*#\{[[:xdigit:]]{8}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{12}\}$} {
            # Device name ok
        }
        {^\\\\\?\\Volume\{[[:xdigit:]]{8}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{4}-[[:xdigit:]]{12}\}\\?$} {
            # Volume name ok. But make sure we trim off any trailing 
            # \ since create_file will open the root dir instead of the device
            set device [string trimright $device \\]
        }
        default {
            # Just to prevent us from opening some file instead
            error "Invalid device name '$device'"
        }
    }

    # http://support.microsoft.com/default.aspx?scid=KB;EN-US;Q165721&
    return [create_file $device -access {generic_read generic_write} \
                -createdisposition open_existing \
                -share {read write}]
}


# Map a partition style code to a symbol
proc twapi::_partition_style_sym {partstyle} {
    set partstyle [lindex {mbr gpt raw} $partstyle]
    if {$partstyle ne ""} {
        return $partstyle
    }
    return "unknown"
}

<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/disk.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
#
# Copyright (c) 2003, 2008 Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# TBD - convert file spec to drive root path

# Get info associated with a drive
proc twapi::get_volume_info {drive args} {

    set drive [_drive_rootpath $drive]

    array set opts [parseargs args {
        all size freespace used useravail type serialnum label maxcomponentlen fstype attr device extents
    } -maxleftover 0]

    if {$opts(all)} {
        # -all option does not cover -type, -extents and -device
        foreach opt {
            all size freespace used useravail serialnum label maxcomponentlen fstype attr
        } {
            set opts($opt) 1
        }
    }

    set result [list ]
    if {$opts(size) || $opts(freespace) || $opts(used) || $opts(useravail)} {
        lassign  [GetDiskFreeSpaceEx $drive] useravail size freespace
        foreach opt {size freespace useravail}  {
            if {$opts($opt)} {
                lappend result -$opt [set $opt]
            }
        }
        if {$opts(used)} {
            lappend result -used [expr {$size - $freespace}]
        }
    }

    if {$opts(type)} {
        set drive_type [get_drive_type $drive]
        lappend result -type $drive_type
    }
    if {$opts(device)} {
        if {[_is_unc $drive]} {
            # UNC paths cannot be used with QueryDosDevice
            lappend result -device ""
        } else {
            lappend result -device [QueryDosDevice [string range $drive 0 1]]
        }
    }

    if {$opts(extents)} {
        set extents {}
        if {! [_is_unc $drive]} {
            trap {
                set device_handle [create_file "\\\\.\\[string range $drive 0 1]" -createdisposition open_existing]
                set bin [device_ioctl $device_handle 0x560000 -outputcount 32]
                if {[binary scan $bin i nextents] != 1} {
                    error "Truncated information returned from ioctl 0x560000"
                }
                set off 8
                for {set i 0} {$i < $nextents} {incr i} {
                    if {[binary scan $bin "@$off i x4 w w" extent(-disknumber) extent(-startingoffset) extent(-extentlength)] != 3} {
                        error "Truncated information returned from ioctl 0x560000"
                    }
                    lappend extents [array get extent]
                    incr off 24; # Size of one extent element
                }
            } onerror {} {
                # Do nothing, device does not support extents or access denied
                # Empty list is returned
            } finally {
                if {[info exists device_handle]} {
                    CloseHandle $device_handle
                }
            }
        }

        lappend result -extents $extents
    }

    if {$opts(serialnum) || $opts(label) || $opts(maxcomponentlen)
        || $opts(fstype) || $opts(attr)} {
        foreach {label serialnum maxcomponentlen attr fstype} \
            [GetVolumeInformation $drive] { break }
        foreach opt {label maxcomponentlen fstype}  {
            if {$opts($opt)} {
                lappend result -$opt [set $opt]
            }
        }
        if {$opts(serialnum)} {
            set low [expr {$serialnum & 0x0000ffff}]
            set high [expr {($serialnum >> 16) & 0x0000ffff}]
            lappend result -serialnum [format "%.4X-%.4X" $high $low]
        }
        if {$opts(attr)} {
            set attrs [list ]
            foreach {sym val} {
                case_preserved_names 2
                unicode_on_disk 4
                persistent_acls 8
                file_compression 16
                volume_quotas 32
                supports_sparse_files 64
                supports_reparse_points 128
                supports_remote_storage 256
                volume_is_compressed 0x8000
                supports_object_ids 0x10000
                supports_encryption 0x20000
                named_streams 0x40000
                read_only_volume 0x80000
                sequential_write_once          0x00100000  
                supports_transactions          0x00200000  
                supports_hard_links            0x00400000  
                supports_extended_attributes   0x00800000  
                supports_open_by_file_id       0x01000000  
                supports_usn_journal           0x02000000  
            } {
                if {$attr & $val} {
                    lappend attrs $sym
                }
            }
            lappend result -attr $attrs
        }
    }

    return $result
}
interp alias {} twapi::get_drive_info {} twapi::get_volume_info


# Check if disk has at least n bytes available for the user (NOT total free)
proc twapi::user_drive_space_available {drv space} {
    return [expr {$space <= [lindex [get_drive_info $drv -useravail] 1]}]
}

# Get the drive type
proc twapi::get_drive_type {drive} {
    # set type [GetDriveType "[string trimright $drive :/\\]:\\"]
    set type [GetDriveType [_drive_rootpath $drive]]
    switch -exact -- $type {
        0 { return unknown}
        1 { return invalid}
        2 { return removable}
        3 { return fixed}
        4 { return remote}
        5 { return cdrom}
        6 { return ramdisk}
    }
}

# Get list of drives
proc twapi::find_logical_drives {args} {
    array set opts [parseargs args {type.arg}]

    set drives [list ]
    foreach drive [_drivemask_to_drivelist [GetLogicalDrives]] {
        if {(![info exists opts(type)]) ||
            [lsearch -exact $opts(type) [get_drive_type $drive]] >= 0} {
            lappend drives $drive
        }
    }
    return $drives
}

# Set the drive label
proc twapi::set_drive_label {drive label} {
    SetVolumeLabel [_drive_rootpath $drive] $label
}

# Maps a drive letter to the given path
proc twapi::map_drive_local {drive path args} {
    array set opts [parseargs args {raw}]

    set drive [string range [_drive_rootpath $drive] 0 1]
    DefineDosDevice $opts(raw) $drive [file nativename $path]
}


# Unmaps a drive letter
proc twapi::unmap_drive_local {drive args} {
    array set opts [parseargs args {
        path.arg
        raw
    } -nulldefault]

    set drive [string range [_drive_rootpath $drive] 0 1]

    set flags $opts(raw)
    setbits flags 0x2;                  # DDD_REMOVE_DEFINITION
    if {$opts(path) ne ""} {
        setbits flags 0x4;              # DDD_EXACT_MATCH_ON_REMOVE
    }
    DefineDosDevice $flags $drive [file nativename $opts(path)]
}


# Callback from C code
proc twapi::_filesystem_monitor_handler {id changes} {
    variable _filesystem_monitor_scripts
    if {[info exists _filesystem_monitor_scripts($id)]} {
        return [uplevel #0 [linsert $_filesystem_monitor_scripts($id) end $id $changes]]
    } else {
        # Callback queued after close. Ignore
    }
}

# Monitor file changes
proc twapi::begin_filesystem_monitor {path script args} {
    variable _filesystem_monitor_scripts

    array set opts [parseargs args {
        {subtree.bool  0}
        {filename.bool 0 0x1}
        {dirname.bool  0 0x2}
        {attr.bool     0 0x4}
        {size.bool     0 0x8}
        {write.bool    0 0x10}
        {access.bool   0 0x20}
        {create.bool   0 0x40}
        {secd.bool     0 0x100}
        {pattern.arg ""}
        {patterns.arg ""}
    } -maxleftover 0]

    if {[string length $opts(pattern)] &&
        [llength $opts(patterns)]} {
        error "Options -pattern and -patterns are mutually exclusive. Note option -pattern is deprecated."
    }

    if {[string length $opts(pattern)]} {
        # Old style single pattern. Convert to new -patterns
        set opts(patterns) [list "+$opts(pattern)"]
    }

    # Change to use \ style path separator as that is what the file monitoring functions return
    if {[llength $opts(patterns)]} {
        foreach pat $opts(patterns) {
            # Note / is replaced by \\ within the pattern
            # since \ needs to be escaped with another \ within
            # string match patterns
            lappend pats [string map [list / \\\\] $pat]
        }
        set opts(patterns) $pats
    }

    set flags [expr { $opts(filename) | $opts(dirname) | $opts(attr) |
                      $opts(size) | $opts(write) | $opts(access) |
                      $opts(create) | $opts(secd)}]

    if {! $flags} {
        # If no options specified, default to all
        set flags 0x17f
    }

    set id [Twapi_RegisterDirectoryMonitor $path $opts(subtree) $flags $opts(patterns)]
    set _filesystem_monitor_scripts($id) $script
    return $id
}

# Stop monitoring of files
proc twapi::cancel_filesystem_monitor {id} {
    variable _filesystem_monitor_scripts
    if {[info exists _filesystem_monitor_scripts($id)]} {
        Twapi_UnregisterDirectoryMonitor $id
        unset _filesystem_monitor_scripts($id)
    }
}


# Get list of volumes
proc twapi::find_volumes {} {
    set vols [list ]
    set found 1
    # Assumes there has to be at least one volume
    lassign [FindFirstVolume] handle vol
    while {$found} {
        lappend vols $vol
        lassign [FindNextVolume $handle] found vol
    }
    FindVolumeClose $handle
    return $vols
}

# Get list of volume mount points
proc twapi::find_volume_mount_points {vol} {
    set mntpts [list ]
    set found 1
    trap {
        lassign  [FindFirstVolumeMountPoint $vol] handle mntpt
    } onerror {TWAPI_WIN32 18} {
        # ERROR_NO_MORE_FILES
        # No volume mount points
        return [list ]
    } onerror {TWAPI_WIN32 3} {
        # Volume does not support them
        return [list ]
    }

    # At least one volume found
    while {$found} {
        lappend mntpts $mntpt
        lassign  [FindNextVolumeMountPoint $handle] found mntpt
    }
    FindVolumeMountPointClose $handle
    return $mntpts
}

# Set volume mount point
proc twapi::mount_volume {volpt volname} {
    # Note we don't use _drive_rootpath for trimming since may not be root path
    SetVolumeMountPoint "[string trimright $volpt /\\]\\" "[string trimright $volname /\\]\\"
}

# Delete volume mount point
proc twapi::unmount_volume {volpt} {
    # Note we don't use _drive_rootpath for trimming since may not be root path
    DeleteVolumeMountPoint "[string trimright $volpt /\\]\\"
}

# Get the volume mounted at a volume mount point
proc twapi::get_mounted_volume_name {volpt} {
    # Note we don't use _drive_rootpath for trimming since may not be root path
    return [GetVolumeNameForVolumeMountPoint "[string trimright $volpt /\\]\\"]
}

# Get the mount point corresponding to a given path
proc twapi::get_volume_mount_point_for_path {path} {
    return [GetVolumePathName [file nativename $path]]
}


# Return the times associated with a file
proc twapi::get_file_times {fd args} {
    array set opts [parseargs args {
        all
        mtime
        ctime
        atime
    } -maxleftover 0]

    # Figure out if fd is a file path, Tcl channel or a handle
    set close_handle false
    if {[file exists $fd]} {
        # It's a file name
        # 0x02000000 -> FILE_FLAG_BACKUP_SEMANTICS, always required in case 
        # opening a directory (even if SeBackupPrivilege is not held
        set h [create_file $fd -createdisposition open_existing -flags 0x02000000]
        set close_handle true
    } elseif {[catch {fconfigure $fd}]} {
        # Not a Tcl channel, See if handle
        if {[pointer? $fd]} {
            set h $fd
        } else {
            error "$fd is not an existing file, handle or Tcl channel."
        }
    } else {
        # Tcl channel
        set h [get_tcl_channel_handle $fd read]
    }

    set result [list ]

    foreach opt {ctime atime mtime} time [GetFileTime $h] {
        if {$opts(all) || $opts($opt)} {
            lappend result -$opt $time
        }
    }

    if {$close_handle} {
        CloseHandle $h
    }

    return $result
}


# Set the times associated with a file
proc twapi::set_file_times {fd args} {

    array set opts [parseargs args {
        mtime.arg
        ctime.arg
        atime.arg
        preserveatime
    } -maxleftover 0 -nulldefault]

    if {$opts(atime) ne "" && $opts(preserveatime)} {
        win32_error 87 "Cannot specify -atime and -preserveatime at the same time."
    }
    if {$opts(preserveatime)} {
        set opts(atime) -1;             # Meaning preserve access to original
    }

    # Figure out if fd is a file path, Tcl channel or a handle
    set close_handle false
    if {[file exists $fd]} {
        if {$opts(preserveatime)} {
            win32_error 87 "Cannot specify -preserveatime unless file is specified as a Tcl channel or a Win32 handle."
        }

        # It's a file name
        # 0x02000000 -> FILE_FLAG_BACKUP_SEMANTICS, always required in case 
        # opening a directory (even if SeBackupPrivilege is not held
        set h [create_file $fd -access {generic_write} -createdisposition open_existing -flags 0x02000000]
        set close_handle true
    } elseif {[catch {fconfigure $fd}]} {
        # Not a Tcl channel, assume a handle
        set h $fd
    } else {
        # Tcl channel
        set h [get_tcl_channel_handle $fd read]
    }

    SetFileTime $h $opts(ctime) $opts(atime) $opts(mtime)

    if {$close_handle} {
        CloseHandle $h
    }

    return
}

# Convert a device based path to a normalized Win32 path with drive letters
# TBD - document
proc twapi::normalize_device_rooted_path {path args} {
    # TBD - keep a cache ?
    # For example, we need to map \Device\HarddiskVolume1 to C:
    # Can only do that by enumerating logical drives
    set npath [file nativename $path]
    if {![string match -nocase {\\Device\\*} $npath]} {
        error "$path is not a valid device based path."
    }
    array set device_map {}
    foreach drive [find_logical_drives] {
        set device_path [lindex [lindex [get_volume_info $drive -device] 1] 0]
        if {$device_path ne ""} {
            set len [string length $device_path]
            if {[string equal -nocase -length $len $path $device_path]} {
                # Prefix matches, must be terminated by end or path separator
                set ch [string index $npath $len]
                if {$ch eq "" || $ch eq "\\"} {
                    set path ${drive}[string range $npath $len end]
                    if {[llength $args]} {
                        upvar [lindex $args 0] retvar
                        set retvar $path
                        return 1
                    } else {
                        return $path
                    }
                }
            }
        }
    }

    if {[llength $args]} {
        return 0
    } else {
        error "Could not map device based path '$path'"
    }
}

proc twapi::flush_channel {chan} {
    flush $chan
    FlushFileBuffers [get_tcl_channel_handle $chan write]
}

# Utility functions

proc twapi::_drive_rootpath {drive} {
    if {[_is_unc $drive]} {
        # UNC
        return "[string trimright $drive ]\\"
    } else {
        return "[string trimright $drive :/\\]:\\"
    }
}

proc twapi::_is_unc {path} {
    return [expr {[string match {\\\\*} $path] || [string match //* $path]}]
}


<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<








































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/etw.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
#
# Copyright (c) 2012-2014 Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

namespace eval twapi {
    # GUID's and event types for ETW.
    variable _etw_mof
    array set _etw_mof {
        provider_name "TwapiETWProvider"
        provider_guid "{B358E9D9-4D82-4A82-A129-BAC098C54746}"
        eventclass_name "TwapiETWEventClass"
        eventclass_guid "{D5B52E95-8447-40C1-B316-539894449B36}"
    }

    # So we don't pollute namespace with temp vars
    apply [list defs {
        foreach {key val} $defs {
            proc etw_twapi_$key {} "return $val"
        }
    } [namespace current]] [array get _etw_mof]

    # Cache of event definitions for parsing MOF  events. Nested dictionary
    # with the following structure (uppercase keys are variables,
    # lower case are constant/tokens, "->" is nested dict, "-" is scalar):
    #  EVENTCLASSGUID ->
    #    classname - name of the class
    #    definitions ->
    #      VERSION ->
    #        EVENTTYPE ->
    #          eventtype - same as EVENTTYPE
    #          eventtypename - name / description for the event type
    #          fieldtypes - ordered list of field types for that event
    #          fields ->
    #            FIELDINDEX ->
    #              type - the field type in string format
    #              fieldtype - the corresponding field type numeric value
    #              extension - the MoF extension qualifier for the field
    #
    # The cache assumes that MOF event definitions are globally identical
    # (ie. same on local and remote systems)
    variable _etw_event_defs
    set _etw_event_defs [dict create]

    # Keeps track of open trace handles for reading
    variable _etw_trace_consumers
    array set _etw_trace_consumers {}

    # Keep track of trace controller handles. Note we do not always
    # need a handle for controller actions. We can also control based
    # on name, for example if some other process has started the trace
    variable _etw_trace_controllers
    array set _etw_trace_controllers {}

    #
    # These record definitions match the lists constructed in the ETW C code
    # Note these are purposely formatted on single line so the record fieldnames
    # print better.

    # Buffer header (EVENT_TRACE_LOGFILE)
    record etw_event_trace_logfile {logfile logger_name current_time buffers_read trace_logfile_header buffer_size filled kernel_trace}

    # TRACE_LOGFILE_HEADER
    record etw_trace_logfile_header {buffer_size version_major version_minor version_submajor version_subminor provider_version processor_count end_time timer_resolution max_file_size logfile_mode buffers_written pointer_size events_lost cpu_mhz time_zone boot_time perf_frequency start_time reserved_flags buffers_lost }

    # TDH based event definitions

    record tdh_event { header buffer_context extended_data data }

    record tdh_event_header { flags event_property tid pid timestamp
        kernel_time user_time processor_time activity_id descriptor provider_guid}
    record tdh_event_buffer_context { processor logger_id }
    record tdh_event_data {event_guid decoder provider_name level_name channel_name keyword_names task_name opcode_name message localized_provider_name activity_id related_activity_id properties }

    record tdh_event_data_descriptor {id version channel level opcode task keywords}

    # Definitions for EVENT_TRACE_LOGFILE
    record tdh_buffer { logfile logger current_time buffers_read header buffer_size filled kernel_trace }

    record tdh_logfile_header { size major_version minor_version sub_version subminor_version provider_version processor_count end_time resolution max_file_size logfile_mode buffers_written pointer_size events_lost cpu_mhz timezone boot_time perf_frequency start_time reserved_flags buffers_lost }

    # MOF based event definitions
    record mof_event {header instance_id parent_instance_id parent_guid data}
    record mof_event_header {type level version tid pid timestamp guid kernel_time user_time processor_time}

    # Standard app visible event definitions. These are made
    # compatible with the evt_* routines
    record etw_event {-eventid -version -channel -level -opcode -task -keywordmask -timecreated -tid -pid -providerguid -usertime -kerneltime -providername -eventguid -channelname -levelname -opcodename -taskname -keywords -properties -message -sid}

    # Record for EVENT_TRACE_PROPERTIES
    # TBD - document
    record etw_trace_properties {logfile trace_name trace_guid buffer_size min_buffers max_buffers max_file_size logfile_mode flush_timer enable_flags clock_resolution age_limit buffer_count free_buffers events_lost buffers_written log_buffers_lost real_time_buffers_lost logger_tid}
}


proc twapi::etw_get_traces {args} {
    parseargs args {detail} -setvars -maxleftover 0
    set sessions {}
    foreach sess [QueryAllTraces] {
        set name [etw_trace_properties trace_name $sess]
        if {$detail} {
            lappend sessions [etw_trace_properties $sess]
        } else {
            lappend sessions $name
        }
    }
    return $sessions
}

if {[twapi::min_os_version 6]} {
    proc twapi::etw_get_provider_guid {name} {
        return [lindex [Twapi_TdhEnumerateProviders $name] 0]
    }
    proc twapi::etw_get_providers {args} {
        parseargs args {
            detail
            {types.arg {mof xml}}
        } -setvars -maxleftover 0
        set providers {}
        foreach rec [Twapi_TdhEnumerateProviders] {
            lassign $rec guid type name
            set type [dict* {0 xml 1 mof} $type]
            if {$type in $types} {
                if {$detail} {
                    lappend providers [list guid $guid type $type name $name]
                } else {
                    lappend providers $name
                }
            }
        }
        return $providers
    }
} else {
    twapi::proc* twapi::etw_get_provider_guid {lookup_name} {
        package require twapi_wmi
    } {
        set wmi [wmi_root -root wmi]
        set oclasses {}
        set providers {}
        # TBD - check if ExecQuery would be faster
        trap {
            # All providers are direct subclasses of the EventTrace class
            set oclasses [wmi_collect_classes $wmi -ancestor EventTrace -shallow]
            foreach ocls $oclasses {
                set quals [$ocls Qualifiers_]
                trap {
                    set name [$quals -with {{Item Description}} -invoke Value 2 {}]
                    if {[string equal -nocase $name $lookup_name]} {
                        return [$quals -with {{Item Guid}} -invoke Value 2 {}]
                    }
                } finally {
                    $quals -destroy
                }
            }
        } finally {
            foreach ocls $oclasses {$ocls -destroy}
            $wmi -destroy
        }
        return ""
    }

    twapi::proc* twapi::etw_get_providers {args} {
        package require twapi_wmi
    } {
        parseargs args { detail {types.arg {mof xml}} } -setvars -maxleftover 0
        if {"mof" ni $types} {
            return {};          # Older systems do not have xml based providers
        }
        set wmi [wmi_root -root wmi]
        set oclasses {}
        set providers {}
        # TBD - check if ExecQuery would be faster
        trap {
            # All providers are direct subclasses of the EventTrace class
            set oclasses [wmi_collect_classes $wmi -ancestor EventTrace -shallow]
            foreach ocls $oclasses {
                set quals [$ocls Qualifiers_]
                trap {
                    set name [$quals -with {{Item Description}} -invoke Value 2 {}]
                    set guid [$quals -with {{Item Guid}} -invoke Value 2 {}]
                    if {$detail} {
                        lappend providers [list guid $guid type mof name $name]
                    } else {
                        lappend providers $name
                    }
                } finally {
                    $quals -destroy
                }
            }
        } finally {
            foreach ocls $oclasses {$ocls -destroy}
            $wmi -destroy
        }
        return $providers
    }
}

twapi::proc* twapi::etw_install_twapi_mof {} {
    package require twapi_wmi
} {
    variable _etw_mof
    
    # MOF definition for our ETW trace event. This is loaded into
    # the system WMI registry so event readers can decode our events
    #
    # Note all strings are NullTerminated and not Counted so embedded nulls
    # will not be handled correctly. The problem with using Counted strings
    # is that the MSDN docs are inconsistent as to whether the count
    # is number of *bytes* or number of *characters* and the existing tools
    # are similarly confused. We avoid this by choosing null terminated
    # strings despite the embedded nulls drawback.
    # TBD - revisit this and see if counted can always be treated as
    # bytes and not characters.
    set mof_template {
        #pragma namespace("\\\\.\\root\\wmi")

        // Keep Description same as provider_name as that is how
        // TDH library identifies it. Else there will be a mismatch
        // between TdhEnumerateProviders and how we internally assume is
        // the provider name
        [dynamic: ToInstance, Description("@provider_name"),
         Guid("@provider_guid")]
        class @provider_name : EventTrace
        {
        };

        [dynamic: ToInstance, Description("TWAPI ETW event class"): Amended,
         Guid("@eventclass_guid")]
        class @eventclass_name : @provider_name
        {
        };

        // NOTE: The EventTypeName is REQUIRED else the MS LogParser app
        // crashes (even though it should not)

        [dynamic: ToInstance, Description("TWAPI log message"): Amended,
         EventType(1), EventTypeName("Message")]
        class @eventclass_name_Message : @eventclass_name
        {
            [WmiDataId(1), Description("Log message"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Message;
        };

        [dynamic: ToInstance, Description("TWAPI variable trace"): Amended,
         EventType(2), EventTypeName("VariableTrace")]
        class @eventclass_name_VariableTrace : @eventclass_name
        {
            [WmiDataId(1), Description("Operation"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Operation;
            [WmiDataId(2), Description("Variable name"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Name;
            [WmiDataId(3), Description("Array index"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Index;
            [WmiDataId(4), Description("Value"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Value;
            [WmiDataId(5), Description("Context"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Context;
        };

        [dynamic: ToInstance, Description("TWAPI execution trace"): Amended,
         EventType(3), EventTypeName("ExecutionTrace")]
        class @eventclass_name_ExecutionTrace : @eventclass_name
        {
            [WmiDataId(1), Description("Operation"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Operation;
            [WmiDataId(2), Description("Executed command"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Command;
            [WmiDataId(3), Description("Status code"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Code;
            [WmiDataId(4), Description("Result"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Result;
            [WmiDataId(5), Description("Context"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Context;
        };

        [dynamic: ToInstance, Description("TWAPI command trace"): Amended,
         EventType(4), EventTypeName("CommandTrace")]
        class @eventclass_name_CommandTrace : @eventclass_name
        {
            [WmiDataId(1), Description("Operation"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Operation;
            [WmiDataId(2), Description("Old command name"): Amended, read, StringTermination("NullTerminated"), Format("w")] string OldName;
            [WmiDataId(3), Description("New command name"): Amended, read, StringTermination("NullTerminated"), Format("w")] string NewName;
            [WmiDataId(4), Description("Context"): Amended, read, StringTermination("NullTerminated"), Format("w")] string Context;
        };
    }

    set mof [string map \
                 [list @provider_name $_etw_mof(provider_name) \
                      @provider_guid $_etw_mof(provider_guid) \
                      @eventclass_name $_etw_mof(eventclass_name) \
                      @eventclass_guid $_etw_mof(eventclass_guid) \
                     ] $mof_template]

    set mofc [twapi::IMofCompilerProxy new]
    twapi::trap {
        $mofc CompileBuffer $mof
    } finally {
        $mofc Release
    }
}

proc twapi::etw_uninstall_twapi_mof {} {
    variable _etw_mof

    set wmi [twapi::_wmi wmi]
    trap {
        set omof [$wmi Get $_etw_mof(provider_name)]
        $omof Delete_
    } finally {
        if {[info exists omof]} {
            $omof destroy
        }
        $wmi destroy
    }
}

proc twapi::etw_twapi_provider_register {} {
    variable _etw_mof
    return [twapi::RegisterTraceGuids $_etw_mof(provider_guid) $_etw_mof(eventclass_guid)]
}

proc twapi::etw_log_message {htrace message {level 4}} {
    set level [_etw_level_to_int $level]
    if {[etw_provider_enable_level] >= $level} {
        # Must match Message event type in MoF definition
        # 1 -> event type for Message
        TraceEvent $htrace 1 $level  [encoding convertto unicode "$message\0"]
    }
}

proc twapi::etw_variable_tracker {htrace name1 name2 op} {
    switch -exact -- $op {
        array -
        unset { set var "" }
        default {
            if {$name2 eq ""} {
                upvar 1 $name1 var
            } else {
                upvar 1 $name1($name2) var
            }
        }
    }

    if {[info level] > 1} {
        set context [info level -1]
    } else {
        set context ""
    }

    # Must match VariableTrace event type in MoF definition
    TraceEvent $htrace 2 0 \
        [encoding convertto unicode "$op\0$name1\0$name2\0$var\0"] \
        [_etw_encode_limited_unicode $context]
}


proc twapi::etw_execution_tracker {htrace command args} {
    set op [lindex $args end]

    switch -exact -- $op {
        enter -
        enterstep {
            set code ""
            set result ""
        }
        leave -
        leavestep {
            lassign $args code result
        }
    }

    if {[info level] > 1} {
        set context [info level -1]
    } else {
        set context ""
    }

    # Must match Execution event type in MoF definition
    TraceEvent $htrace 3 0 \
        [encoding convertto unicode "$op\0"] \
        [_etw_encode_limited_unicode $command] \
        [encoding convertto unicode "$code\0"] \
        [_etw_encode_limited_unicode $result] \
        [_etw_encode_limited_unicode $context]
}


proc twapi::etw_command_tracker {htrace oldname newname op} {
    if {[info level] > 1} {
        set context [info level -1]
    } else {
        set context ""
    }
    # Must match CommandTrace event type in MoF definition
    TraceEvent $htrace 4 0 \
        [encoding convertto unicode "$op\0$oldname\0$newname\0"] \
        [_etw_encode_limited_unicode $context]
}

proc twapi::etw_parse_mof_event_class {ocls} {
    # Returns a dict 
    # First level key - event type (integer)
    # See description of _etw_event_defs for rest of the structure

    set result [dict create]

    # Iterate over the subclasses, collecting the event metadata
    # Create a forward only enumerator for efficiency
    # wbemFlagUseAmendedQualifiers|wbemFlagReturnImmediately|wbemFlagForwardOnly
    # wbemQueryFlagsShallow
    # -> 0x20031
    $ocls -with {{SubClasses_ 0x20031}} -iterate -cleanup osub {
        # The subclass must have the eventtype property
        # We fetch as a raw value so we can tell the
        # original type
        if {![catch {
            $osub -with {
                Qualifiers_
                {Item EventType}
            } -invoke Value 2 {} -raw 1
        } event_types]} {

            # event_types is a raw value with a type descriptor as elem 0
            if {[variant_type $event_types] & 0x2000} {
                # It is VT_ARRAY so value is already a list
                set event_types [variant_value $event_types 0 0 0]
            } else {
                set event_types [list [variant_value $event_types 0 0 0]]
            }

            set event_type_names {}
            catch {
                set event_type_names [$osub -with {
                    Qualifiers_
                    {Item EventTypeName}
                } -invoke Value 2 {} -raw 1]
                # event_type_names is a raw value with a type descriptor as elem 0
                # It is IMPORTANT to check this else we cannot distinguish
                # between a array (list) and a string with spaces
                if {[variant_type $event_type_names] & 0x2000} {
                    # It is VT_ARRAY so value is already a list
                    set event_type_names [variant_value $event_type_names 0 0 0]
                } else {
                    # Scalar value. Make into a list
                    set event_type_names [list [variant_value $event_type_names 0 0 0]]
                }
            }

            # The subclass has a EventType property. Pick up the
            # field definitions.
            set fields [dict create]
            $osub -with Properties_ -iterate -cleanup oprop {
                set quals [$oprop Qualifiers_]
                # Event fields will have a WmiDataId qualifier
                if {![catch {$quals -with {{Item WmiDataId}} Value} wmidataid]} {
                    # Yep this is a field, figure out its type
                    set type [_etw_decipher_mof_event_field_type $oprop $quals]
                    dict set type -fieldname [$oprop -get Name]
                    dict set fields $wmidataid $type
                }
                $quals destroy
            }
                    
            # Process the records to put the fields in order based on
            # their wmidataid. If any info is missing or inconsistent
            # we will mark the whole event type class has undecodable.
            # Ids begin from 1.
            set fieldtypes {}
            for {set id 1} {$id <= [dict size $fields]} {incr id} {
                if {![dict exists $fields $id]} {
                    # Discard all type info - missing type info
                    debuglog "Missing id $id for event type(s) $event_types for  EventTrace Mof Class [$ocls -with {{SystemProperties_} {Item __CLASS}} Value]"
                    set fieldtypes {}
                    break;
                }
                lappend fieldtypes [dict get $fields $id -fieldname] [dict get $fields $id -fieldtype]
            }

            foreach event_type $event_types event_type_name $event_type_names {
                dict set result -definitions $event_type [dict create -eventtype $event_type -eventtypename $event_type_name -fields $fields -fieldtypes $fieldtypes]
            }
        }
    }

    if {[dict size $result] == 0} {
        return {}
    } else {
        dict set result -classname [$ocls -with {SystemProperties_ {Item __CLASS}} Value]
        return $result
    }
}

# Deciphers an event  field type

proc twapi::_etw_decipher_mof_event_field_type {oprop oquals} {
    # Maps event field type strings to enums to pass to the C code
    # 0 should be unmapped. Note some are duplicates because they
    # are the same format. Some are legacy formats not explicitly documented
    # in MSDN but found in the sample code.
    # Reference - Event Tracing MOF Qualifiers http://msdn.microsoft.com/en-us/library/windows/desktop/aa363800(v=vs.85).aspx
    set etw_fieldtypes {
        string  1
        stringnullterminated 1
        wstring 2
        wstringnullterminated 2
        stringcounted 3
        stringreversecounted 4
        wstringcounted 5
        wstringreversecounted 6
        boolean 7
        sint8 8
        uint8 9
        csint8 10
        cuint8 11
        sint16 12
        uint16 13
        uint32 14
        sint32 15
        sint64 16
        uint64 17
        xsint16 18
        xuint16 19
        xsint32 20
        xuint32 21
        xsint64 22
        xuint64 23
        real32 24
        real64 25
        object 26
        char16 27
        uint8guid 28
        objectguid 29
        objectipaddrv4 30
        uint32ipaddr 30
        objectipaddr 30
        objectipaddrv6 31
        objectvariant 32
        objectsid 33
        uint64wmitime 34
        objectwmitime 35
        uint16port 38
        objectport 39
        datetime 40
        stringnotcounted 41
        wstringnotcounted 42
        pointer 43
        sizet   43
    }

    # On any errors, we will set type to unknown or unsupported
    set type unknown
    set quals(extension)  "";   # Hint for formatting for display

    if {![catch {
        $oquals -with {{Item Pointer}} Value
    }]} {
        # Actual value does not matter
        # If the Pointer qualifier exists, ignore everything else
        set type pointer
    } elseif {![catch {
        $oquals -with {{Item PointerType}} Value
    }]} {
        # Actual value does not matter
        # Some apps mistakenly use PointerType instead of Pointer
        set type pointer
    } else {
        catch {
            set type [string tolower [$oquals -with {{Item CIMTYPE}} Value]]

            # The following qualifiers may or may not exist
            # TBD - not all may be required to be retrieved
            # NOTE: MSDN says some qualifiers are case sensitive!
            foreach qual {BitMap BitValues Extension Format Pointer StringTermination ValueMap Values ValueType XMLFragment} {
                # catch in case it does not exist
                set lqual [string tolower $qual]
                set quals($lqual) ""
                catch {
                    set quals($lqual) [$oquals -with [list [list Item $qual]] Value]
                }
            }
            set type [string tolower "$quals(format)${type}$quals(stringtermination)"]
            set quals(extension) [string tolower $quals(extension)]
            # Not all extensions affect how the event field is extracted
            # e.g. the noprint value
            if {$quals(extension) in {ipaddr ipaddrv4 ipaddrv6 port variant wmitime guid sid}} {
                append type $quals(extension)
            } elseif {$quals(extension) eq "sizet"} {
                set type sizet
            }
        }
    }

    # Cannot handle arrays yet - TBD
    if {[$oprop -get IsArray]} {
        set type "arrayof$type"
    }

    if {![dict exists $etw_fieldtypes $type]} {
        set fieldtype 0
    } else {
        set fieldtype [dict get $etw_fieldtypes $type]
    }

    return [dict create -type $type -fieldtype $fieldtype -extension $quals(extension)]
}

proc twapi::etw_find_mof_event_classes {oswbemservices args} {
    # Return all classes where a GUID or name matches

    # To avoid iterating the tree multiple times, separate out the guids
    # and the names and use separator comparators

    set guids {}
    set names {}

    foreach arg $args {
        if {[Twapi_IsValidGUID $arg]} {
            # GUID's can be multiple format, canonicalize for lsearch
            lappend guids [canonicalize_guid $arg]
        } else {
            lappend names $arg
        }
    }

    # Note there can be multiple versions sharing a single guid so
    # we cannot use the wmi_collect_classes "-first" option to stop the
    # search when one is found.

    set name_matcher [lambda* {names val} {
        ::tcl::mathop::>= [lsearch -exact -nocase $names $val] 0
    } :: $names]
    set guid_matcher [lambda* {guids val} {
        ::tcl::mathop::>= [lsearch -exact -nocase $guids $val] 0
    } :: $guids]

    set named_classes {}
    if {[llength $names]} {
        foreach name $names {
            catch {lappend named_classes [$oswbemservices Get $name]}
        }
    }

    if {[llength $guids]} {
        set guid_classes [wmi_collect_classes $oswbemservices -ancestor EventTrace -matchqualifiers [list Guid $guid_matcher]]
    } else {
        set guid_classes {}
    }

    return [concat $guid_classes $named_classes]
}

proc twapi::etw_get_all_mof_event_classes {oswbemservices} {
    return [twapi::wmi_collect_classes $oswbemservices -ancestor EventTrace -matchqualifiers [list Guid ::twapi::true]]
}

proc twapi::etw_load_mof_event_class_obj {oswbemservices ocls} {
    variable _etw_event_defs
    set quals [$ocls Qualifiers_]
    trap {
        set guid [$quals -with {{Item Guid}} Value]
        set vers ""
        catch {set vers [$quals -with {{Item EventVersion}} Value]}
        set def [etw_parse_mof_event_class $ocls]
        # Class may be a provider, not a event class in which case
        # def will be empty
        if {[dict size $def]} {
            dict set _etw_event_defs [canonicalize_guid $guid] $vers $def
        }
    } finally {
        $quals destroy
    }
}

proc twapi::etw_load_mof_event_classes {oswbemservices args} {
    if {[llength $args] == 0} {
        set oclasses [etw_get_all_mof_event_classes $oswbemservices]
    } else {
        set oclasses [etw_find_mof_event_classes $oswbemservices {*}$args]
    }

    foreach ocls $oclasses {
        trap {
            etw_load_mof_event_class_obj $oswbemservices $ocls
        } finally {
            $ocls destroy
        }
    }
}

proc twapi::etw_open_file {path} {
# TBD - PROCESS_TRACE_MODE_RAW_TIMESTAMP
    variable _etw_trace_consumers

    set path [file normalize $path]

    set htrace [OpenTrace $path 0]
    set _etw_trace_consumers($htrace) $path
    return $htrace
}

proc twapi::etw_open_session {sessionname} {
# TBD - PROCESS_TRACE_MODE_RAW_TIMESTAMP
    variable _etw_trace_consumers

    set htrace [OpenTrace $sessionname 1]
    set _etw_trace_consumers($htrace) $sessionname
    return $htrace
}

proc twapi::etw_close_session {htrace} {
    variable _etw_trace_consumers

    if {! [info exists _etw_trace_consumers($htrace)]} {
        badargs! "Cannot find trace session with handle $htrace"
    }

    CloseTrace $htrace
    unset _etw_trace_consumers($htrace)
    return
}


proc twapi::etw_process_events {args} {
    array set opts [parseargs args {
        callback.arg
        start.arg
        end.arg
    } -nulldefault]

    if {[llength $args] == 0} {
        error "At least one trace handle must be specified."
    }

    return [ProcessTrace $args $opts(callback) $opts(start) $opts(end)]
}

proc twapi::etw_open_formatter {} {
    variable _etw_formatters

    if {[etw_force_mof] || ![twapi::min_os_version 6 0]} {
        uplevel #0 package require twapi_wmi
        # Need WMI MOF definitions
        set id mof[TwapiId]
        dict set _etw_formatters $id OSWBemServices [wmi_root -root wmi]
    } else {
        # Just a dummy if using a TDH based api
        set id tdh[TwapiId]
        # Nothing to set as yet but for consistency with MOF implementation
        dict set _etw_formatters $id {}
    }
    return $id
}

proc twapi::etw_close_formatter {formatter} {
    variable _etw_formatters
    if {[dict exists $_etw_formatters $formatter OSWBemServices]} {
        [dict get $_etw_formatters $formatter OSWBemServices] -destroy
    }

    dict unset _etw_formatters $formatter
    if {[dict size $_etw_formatters] == 0} {
        variable _etw_event_defs
        # No more formatters
        # Clear out event defs cache which can be quite large
        # Really only needed for mof but doesn't matter
        set _etw_event_defs {}
    }

    return
}

proc twapi::etw_format_events {formatter args} {
    variable _etw_formatters

    if {![dict exists $_etw_formatters $formatter]} {
        # We could actually just init ourselves but we want to force
        # consistency and caller to release wmi COM object
        badargs! "Invalid ETW formatter id \"$formatter\""
    }

    set events {}
    if {[dict exists $_etw_formatters $formatter OSWBemServices]} {
        set oswbemservices [dict get $_etw_formatters $formatter OSWBemServices]
        foreach {bufd rawevents} $args {
            lappend events [_etw_format_mof_events $oswbemservices $bufd $rawevents]
        }
    } else {
        foreach {bufd rawevents} $args {
            lappend events [_etw_format_tdh_events $bufd $rawevents]
        }
    }

    # Return as a recordarray
    return [list [etw_event] [lconcat {*}$events]]
}

proc twapi::_etw_format_tdh_events {bufdesc events} {
    
    set bufhdr [etw_event_trace_logfile trace_logfile_header $bufdesc]
    set timer_resolution [etw_trace_logfile_header timer_resolution $bufhdr]
    set private_session [expr {0x800 & [etw_trace_logfile_header logfile_mode $bufhdr]}]
    set pointer_size [etw_trace_logfile_header pointer_size $bufhdr]

    set formatted_events {}
    foreach event $events {
        array set fields [tdh_event $event]
        set formatted_event [tdh_event_header descriptor $fields(header)]
        lappend formatted_event {*}[tdh_event_header select $fields(header) {timestamp tid pid provider_guid}]
        if {$private_session} {
            lappend formatted_event [expr {[tdh_event_header processor_time $fields(header)] * $timer_resolution}] 0
        } else {
            lappend formatted_event [expr {[tdh_event_header user_time $fields(header)] * $timer_resolution}] [expr {[tdh_event_header kernel_time $fields(header)] * $timer_resolution}]
        }
        lappend formatted_event {*}[tdh_event_data select $fields(data) {provider_name event_guid channel_name level_name opcode_name task_name keyword_names properties message}] [dict* $fields(extended_data) sid ""]

        lappend formatted_events $formatted_event
    }
    return $formatted_events
}

proc twapi::_etw_format_mof_events {oswbemservices bufdesc events} {
    variable _etw_event_defs

    # TBD - it may be faster to special case NT kernel events as per
    # the structures defined in http://msdn.microsoft.com/en-us/library/windows/desktop/aa364083(v=vs.85).aspx
    # However, the MSDN warns that structures should not be created from
    # MOF classes as alignment restrictions might be different
    array set missing {}
    foreach event $events {
        set guid [mof_event_header guid [mof_event header $event]]
        if {! [dict exists $_etw_event_defs $guid]} {
            set missing($guid) ""
        }
    }

    if {[array size missing]} {
        etw_load_mof_event_classes $oswbemservices {*}[array names missing]
    }

    set bufhdr [etw_event_trace_logfile trace_logfile_header $bufdesc]
    set timer_resolution [etw_trace_logfile_header timer_resolution $bufhdr]
    set private_session [expr {0x800 & [etw_trace_logfile_header logfile_mode $bufhdr]}]
    set pointer_size [etw_trace_logfile_header pointer_size $bufhdr]

    # TBD - what should provider_guid be for each event?
    set provider_guid ""

    set formatted_events {}
    foreach event $events {
        array set hdr [mof_event_header [mof_event header $event]]
        
        # Formatted event must match field sequence in etw_event record
        set formatted_event [list 0 $hdr(version) 0 $hdr(level) $hdr(type) 0 0 \
                                 $hdr(timestamp) $hdr(tid) $hdr(pid) $provider_guid]
        
        if {$private_session} {
            lappend formatted_event [expr {$hdr(processor_time) * $timer_resolution}] 0
        } else {
            lappend formatted_event [expr {$hdr(user_time) * $timer_resolution}] [expr {$hdr(kernel_time) * $timer_resolution}]
        }

        if {[dict exists $_etw_event_defs $hdr(guid) $hdr(version) -definitions $hdr(type)]} {
            set eventclass [dict get $_etw_event_defs $hdr(guid) $hdr(version) -classname]
            set mof [dict get $_etw_event_defs $hdr(guid) $hdr(version) -definitions $hdr(type)]
            set eventtypename [dict get $mof -eventtypename]
            set properties [Twapi_ParseEventMofData \
                                [mof_event data $event] \
                                [dict get $mof -fieldtypes] \
                                $pointer_size]
        } elseif {[dict exists $_etw_event_defs $hdr(guid) "" -definitions $hdr(type)]} {
            # If exact version not present, use one without
            # a version
            set eventclass [dict get $_etw_event_defs $hdr(guid) "" -classname]
            set mof [dict get $_etw_event_defs $hdr(guid) "" -definitions $hdr(type)]
            set eventtypename [dict get $mof -eventtypename]
            set properties [Twapi_ParseEventMofData \
                                [mof_event data $event] \
                                [dict get $mof -fieldtypes] \
                                $pointer_size]
        } else {
            # No definition. Create an entry so we know we already tried
            # looking this up and don't keep retrying later
            dict set _etw_event_defs $hdr(guid) {}

            # Nothing we can add to the event. Pass on with defaults
            set eventtypename $hdr(type)
            # Try to get at least the class name
            if {[dict exists $_etw_event_defs $hdr(guid) $hdr(version) -classname]} {
                set eventclass [dict get $_etw_event_defs $hdr(guid) $hdr(version) -classname]
            } elseif {[dict exists $_etw_event_defs $hdr(guid) "" -classname]} {
                set eventclass [dict get $_etw_event_defs $hdr(guid) "" -classname]
            } else {
                set eventclass ""
            }
            set properties [list _mofdata [mof_event data $event]]
        }

        # eventclass -> provider_name
        # TBD - should we get the Provider qualifier from Mof as provider_name? (Does it even exist?)
        # mofformatteddata -> properties
        # level name is not localized. Oh well, too bad
        set level_name [dict* {0 {Log Always} 1 Critical 2 Error 3 Warning 4 Informational 5 Debug} $hdr(level)]
        lappend formatted_event $eventclass $hdr(guid) "" $level_name $eventtypename "" "" $properties "" ""

        lappend formatted_events $formatted_event
    }

    return $formatted_events
}

proc twapi::etw_format_event_message {message properties} {
    if {$message ne ""} {
        set params {}
        foreach {propname propval} $properties {
            # Properties are always a list, even when scalars because
            # there is no way of distinguishing between a scalar and
            # an array of size 1 in the return values from TDH
            lappend params [join $propval {, }]
        }
        catch {set message [format_message -fmtstring $message -params $params]}
    }
    return $message
}


proc twapi::etw_dump_to_file {args} {
    array set opts [parseargs args {
        {output.arg stdout}
        {limit.int -1}
        {format.arg csv {csv list}}
        {separator.arg ,}
        {fields.arg {-timecreated -levelname -providername -pid -taskname -opcodename -message}}
        {filter.arg {}}
    }]

    if {$opts(format) eq "csv"} {
        package require csv
    }
    if {$opts(output) in [chan names]} {
        # Writing to a channel
        set outfd $opts(output)
        set do_close 0
    } else {
        if {[file exists $opts(output)]} {
            error "File $opts(output) already exists."
        }
        set outfd [open $opts(output) a]
        set do_close 1
    }

    set formatter [etw_open_formatter]
    trap {
        set varname ::twapi::_etw_dump_ctr[TwapiId]
        set $varname 0;         # Yes, set $varname, not set varname
        set htraces {}
        foreach arg $args {
            if {[file exists $arg]} {
                lappend htraces [etw_open_file $arg]
            } else {
                lappend htraces [etw_open_session $arg]
            }
        }

        if {$opts(format) eq "csv"} {
            puts $outfd [csv::join $opts(fields) $opts(separator)]
        }
        if {[llength $htraces] == 0} {
            return
        }
        # This is written using a callback to basically test the callback path
        set callback [list apply {
            {options outfd counter_varname max formatter bufd events}
            {
                array set opts $options
                set events [etw_format_events $formatter $bufd $events]
                foreach event [recordarray getlist $events -format dict -filter $opts(filter)] {
                    if {$max >= 0 && [set $counter_varname] >= $max} {
                        return -code break
                    }
                    array set fields $event
                    if {"-message" in $opts(fields)} {
                        set fields(-message) [etw_format_event_message $fields(-message) $fields(-properties)]
                    }
                    if {"-properties" in $opts(fields)} {
                        set fmtdata $fields(-properties)
                        if {[dict exists $fmtdata mofdata]} {
                            # Only show 32 bytes
                            binary scan [string range [dict get $fmtdata mofdata] 0 31] H* hex
                            dict set fmtdata mofdata [regsub -all (..) $hex {\1 }]
                        }
                        set fields(-properties) $fmtdata
                    }
                    set fmtlist {}
                    foreach field $opts(fields) {
                        lappend fmtlist $fields($field)
                    }
                    if {$opts(format) eq "csv"} {
                        puts $outfd [csv::join $fmtlist $opts(separator)]
                    } else {
                        puts $outfd $fmtlist
                    }
                    incr $counter_varname
                }
            }
        } [array get opts] $outfd $varname $opts(limit) $formatter]

        # Process the events using the callback
        etw_process_events -callback $callback {*}$htraces

    } finally {
        unset -nocomplain $varname
        foreach htrace $htraces {
            etw_close_session $htrace
        }
        if {$do_close} {
            close $outfd
        } else {
            flush $outfd
        }
        etw_close_formatter $formatter
    }
}

proc twapi::etw_dump_to_list {args} {
    set htraces {}
    set formatter [etw_open_formatter]
    trap {
        foreach arg $args {
            if {[file exists $arg]} {
                lappend htraces [etw_open_file $arg]
            } else {
                lappend htraces [etw_open_session $arg]
            }
        }
        return [recordarray getlist [etw_format_events $formatter {*}[etw_process_events {*}$htraces]]]
    } finally {
        foreach htrace $htraces {
            etw_close_session $htrace
        }
        etw_close_formatter $formatter
    }
}

proc twapi::etw_dump {args} {
    set htraces {}
    set formatter [etw_open_formatter]
    trap {
        foreach arg $args {
            if {[file exists $arg]} {
                lappend htraces [etw_open_file $arg]
            } else {
                lappend htraces [etw_open_session $arg]
            }
        }
        return [recordarray get [etw_format_events $formatter {*}[etw_process_events {*}$htraces]]]
    } finally {
        foreach htrace $htraces {
            etw_close_session $htrace
        }
        etw_close_formatter $formatter
    }
}


proc twapi::etw_start_trace {session_name args} {
    variable _etw_trace_controllers
    
    # Specialized for kernel debugging - {bufferingmode {} 0x400}
    # Not supported until Win7 {noperprocessorbuffering {} 0x10000000}
    # Not clear what conditions it can be used {usekbytesforsize {} 0x2000}
    array set opts [parseargs args {
        traceguid.arg
        logfile.arg
        buffersize.int
        minbuffers.int
        maxbuffers.int
        maxfilesize.int
        flushtimer.int
        enableflags.int
        {filemode.arg circular {sequential append rotate circular}}
        {clockresolution.sym system {qpc 1  system 2 cpucycle 3}}
        {private.bool 0 0x800}
        {realtime.bool 0 0x100}
        {secure.bool 0 0x80}
        {privateinproc.bool 0 0x20800}
        {sequence.sym none {none 0 local 0x8000 global 0x4000}}
        {paged.bool 0 0x01000000}
        {preallocate.bool 0 0x20}
    } -maxleftover 0]

    if {!$opts(realtime) && (![info exists opts(logfile)] || $opts(logfile) eq "")} {
        badargs! "Log file name must be specified if real time mode is not in effect"
    }

    if {[string equal -nocase $session_name "NT Kernel Logger"] &&
        $opts(filemode) eq "rotate"} {
        error "Option -filemode cannot have value \"rotate\" for NT Kernel Logger"
    }

    set logfilemode 0
    switch -exact $opts(filemode) {
        sequential {
            if {[info exists opts(maxfilesize)]} {
                # 1 -> EVENT_TRACE_FILE_MODE_SEQUENTIAL 
                set logfilemode [expr {$logfilemode | 1}]
            } else {
                # 0 -> EVENT_TRACE_FILE_MODE_NONE
                # set logfilemode [expr {$logfilemode | 0}]
            }
        }
        circular {
            # 2 -> EVENT_TRACE_FILE_MODE_CIRCULAR
            set logfilemode [expr {$logfilemode | 2}]
            if {![info exists opts(maxfilesize)]} {
                set opts(maxfilesize) 1; # 1MB default
            }
        }
        rotate {
            if {$opts(private) || $opts(privateinproc)} {
                if {![min_os_version 6 2]} {
                    badargs! "Option -filemode must not be \"rotate\" for private traces"
                }
            }

            # 8 -> EVENT_TRACE_FILE_MODE_NEWFILE
            set logfilemode [expr {$logfilemode | 8}]
            if {![info exists opts(maxfilesize)]} {
                set opts(maxfilesize) 1; # 1MB default
            }
        }
        append {
            if {$opts(private) || $opts(privateinproc) || $opts(realtime)} {
                badargs! "Option -filemode must not be \"append\" for private or realtime traces"
            }
            # 4 -> EVENT_TRACE_FILE_MODE_APPEND
            # Not clear what to do about maxfilesize. Keep as is for now
            set logfilemode [expr {$logfilemode | 4}]
        }
    }

    if {![info exists opts(maxfilesize)]} {
        set opts(maxfilesize) 0
    }

    if {$opts(realtime) && ($opts(private) || $opts(privateinproc))} {
        badargs! "Option -realtime is incompatible with options -private and -privateinproc"
    }

    foreach opt {traceguid logfile buffersize minbuffers maxbuffers flushtimer enableflags maxfilesize} {
        if {[info exists opts($opt)]} {
            lappend params -$opt $opts($opt)
        }
    }

    set logfilemode [expr {$logfilemode | $opts(sequence)}]

    set logfilemode [tcl::mathop::| $logfilemode $opts(realtime) $opts(private) $opts(privateinproc) $opts(secure) $opts(paged) $opts(preallocate)]

    lappend params -logfilemode $logfilemode

    if {$opts(filemode) eq "append" && $opts(clockresolution) != 2} {
        error "Option -clockresolution must be set to 'system' if -filemode is append"
    }

    if {($opts(filemode) eq "rotate" || $opts(preallocate)) &&
        $opts(maxfilesize) == 0} {
        error "Option -maxfilesize must also be specified with -preallocate or -filemodenewfile."
    }

    lappend params -clockresolution $opts(clockresolution)

    trap {
        set h [StartTrace $session_name $params]
        set _etw_trace_controllers($h) $session_name
        return $h
    } onerror {TWAPI_WIN32 5} {
        return -options [trapoptions] "Access denied. This may be because the process does not have permission to create the specified logfile or because it is not running under an account permitted to control ETW traces."
    }
}

proc twapi::etw_start_kernel_trace {events args} {
    
    set enableflags 0

    # Note sysconfig is a dummy event. It is always logged.
    set eventmap {
        process 0x00000001
        thread 0x00000002
        imageload 0x00000004
        diskio 0x00000100
        diskfileio 0x00000200
        pagefault 0x00001000
        hardfault 0x00002000
        tcpip 0x00010000
        registry 0x00020000
        dbgprint 0x00040000
        sysconfig 0x00000000
    }

    if {"diskfileio" in $events} {
        lappend events diskio;  # Required by diskfileio
    }

    if {[min_os_version 6]} {
        lappend eventmap {*}{
            processcounter 0x00000008
            contextswitch 0x00000010
            dpc 0x00000020
            interrupt 0x00000040
            systemcall 0x00000080
            diskioinit 0x00000400
            alpc 0x00100000
            splitio 0x00200000
            driver 0x00800000
            profile 0x01000000
            fileio 0x02000000
            fileioinit 0x04000000
        }

        if {"diskio" in $events} {
            lappend events diskioinit
        }
    }

    if {[min_os_version 6 1]} {
        lappend eventmap {*}{
            dispatcher 0x00000800
            virtualalloc 0x00004000
        }
    }

    if {[min_os_version 6 2]} {
        lappend eventmap {*}{
            vamap 0x00008000
        }
        if {"sysconfig" ni $events} {
            # EVENT_TRACE_FLAG_NO_SYSCONFIG 
            set enableflags [expr {$enableflags | 0x10000000}]
        }
    }

    foreach event $events {
        set enableflags [expr {$enableflags | [dict! $eventmap $event]}]
    }

    # Name "NT Kernel Logger" is hardcoded in Windows
    # GUID is 9e814aad-3204-11d2-9a82-006008a86939 but does not need to be
    # specified. Note kernel logger cannot use paged memory so 
    # -paged 0 is required
    return [etw_start_trace "NT Kernel Logger" -enableflags $enableflags {*}$args -paged 0]
}

proc twapi::etw_enable_provider {htrace guid enableflags level} {
    set guid [_etw_provider_guid $guid]
    return [EnableTrace 1 $enableflags [_etw_level_to_int $level] $guid $htrace]
}

proc twapi::etw_disable_provider {htrace guid} {
    set guid [_etw_provider_guid $guid]
    return [EnableTrace 0 -1 5 $guid $htrace]
}

proc twapi::etw_control_trace {action session args} {
    variable _etw_trace_controllers

    if {[info exists _etw_trace_controllers($session)]} {
        set sessionhandle $session
    } else {
        set sessionhandle 0
        set sessionname $session
    }

    set action [dict get {
        query  0
        stop   1
        update 2
        flush  3
    } $action]

    array set opts [parseargs args {
        traceguid.arg
        logfile.arg
        maxbuffers.int
        flushtimer.int
        enableflags.int
        realtime.bool
    } -maxleftover 0]

    set params {}

    if {[info exists opts(realtime)]} {
        if {$opts(realtime)} {
            lappend params -logfilemode 0x100; # EVENT_TRACE_REAL_TIME_MODE 
        } else {
            lappend params -logfilemode 0
        }
    }

    if {[info exists opts(traceguid)]} {
        append params -traceguid $opts(traceguid)
    }

    if {[info exists sessionname]} {
        lappend params -sessionname $sessionname
    }

    if {$action == 2} {
        # update
        foreach opt {logfile flushtimer enableflags maxbuffers} {
            if {[info exists opts($opt)]} {
                lappend params -$opt $opts($opt)
            }
        }
    }

    return [etw_trace_properties [ControlTrace $action $sessionhandle $params]]
}

interp alias {} twapi::etw_update_trace {} twapi::etw_control_trace update

proc twapi::etw_stop_trace {trace} {
    variable _etw_trace_controllers
    set stats [etw_control_trace stop $trace]
    unset -nocomplain _etw_trace_controllers($trace)
    return $stats
}

proc twapi::etw_flush_trace {trace} {
    return [etw_control_trace flush $trace]
}

proc twapi::etw_query_trace {trace} {
    set d [etw_control_trace query $trace]
    set cres [lindex  {{} qpc system cpucycle} [dict get $d clock_resolution]]
    if {$cres ne ""} {
        dict set d clock_resolution $cres
    }

    #TBD - check whether -maxfilesize needs to be massaged

    return $d
}



#
# Helper functions
#


# Return binary unicode with truncation if necessary
proc twapi::_etw_encode_limited_unicode {s {max 80}} {
    if {[string length $s] > $max} {
        set s "[string range $s 0 $max-3]..."
    }
    return [encoding convertto unicode "$s\0"]
}

# Used for development/debug to see what all types are in use
proc twapi::_etw_get_types {} {
    dict for {g gval} $::twapi::_etw_event_defs {
        dict for {ver verval} $gval {
            dict for {eventtype eval} [dict get $verval -definitions] {
                dict for {id idval} [dict get $eval -fields] {
                    dict set types [dict get $idval -type] [dict get $verval -classname] $eventtype $id
                }
            }
        }
    }
    return $types
}

proc twapi::_etw_level_to_int {level} {
    return [dict* {verbose 5 information 4 info 4 informational 4 warning 3 error 2 fatal 1 critical 1} [string tolower $level]]
}

# Map provider guid/name to guid
proc twapi::_etw_provider_guid {lookup} {
    if {[Twapi_IsValidGUID $lookup]} {
        return $lookup
    }
    set guid [etw_get_provider_guid $lookup]
    if {$guid eq ""} {
        badargs! "Provider \"$lookup\" not found."
    }
    return $guid
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<


































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/eventlog.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
#
# Copyright (c) 2004-2012, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

package require registry

namespace eval twapi {
    # We maintain caches so we do not do lookups all the time
    # TBD - have a means of clearing this out
    variable _eventlog_message_cache
    set _eventlog_message_cache {}
}


# Read the event log
proc twapi::eventlog_read {hevl args} {
    _eventlog_valid_handle $hevl read raise

    array set opts [parseargs args {
        seek.int
        {direction.arg forward}
    }]

    if {[info exists opts(seek)]} {
        set flags 2;                    # Seek
        set offset $opts(seek)
    } else {
        set flags 1;                    # Sequential read
        set offset 0
    }

    switch -glob -- $opts(direction) {
        ""    -
        forw* {
            setbits flags 4
        }
        back* {
            setbits flags 8
        }
        default {
            error "Invalid value '$opts(direction)' for -direction option"
        }
    }

    set results [list ]

    trap {
        set recs [ReadEventLog $hevl $flags $offset]
    } onerror {TWAPI_WIN32 38} {
        # EOF - no more
        set recs [list ]
    }
    foreach event $recs {
        dict set event -type [string map {0 success 1 error 2 warning 4 information 8 auditsuccess 16 auditfailure} [dict get $event -level]]
        lappend results $event
    }

    return $results
}


# Get the oldest event log record index. $hevl must be read handle
proc twapi::eventlog_oldest {hevl} {
    _eventlog_valid_handle $hevl read raise
    return [GetOldestEventLogRecord $hevl]
}

# Get the event log record count. $hevl must be read handle
proc twapi::eventlog_count {hevl} {
    _eventlog_valid_handle $hevl read raise
    return [GetNumberOfEventLogRecords $hevl]
}

# Check if the event log is full. $hevl may be either read or write handle
# (only win2k plus)
proc twapi::eventlog_is_full {hevl} {
    # Does not matter if $hevl is read or write, but verify it is a handle
    _eventlog_valid_handle $hevl read
    return [Twapi_IsEventLogFull $hevl]
}

# Backup the event log
proc twapi::eventlog_backup {hevl file} {
    _eventlog_valid_handle $hevl read raise
    BackupEventLog $hevl $file
}

# Clear the event log
proc twapi::eventlog_clear {hevl args} {
    _eventlog_valid_handle $hevl read raise
    array set opts [parseargs args {backup.arg} -nulldefault]
    ClearEventLog $hevl $opts(backup)
}


# Formats the given event log record message
# 
proc twapi::eventlog_format_message {rec args} {
    variable _eventlog_message_cache

    array set opts [parseargs args {
        width.int
        langid.int
    } -nulldefault]

    set source  [dict get $rec -source]
    set eventid [dict get $rec -eventid]

    if {[dict exists $_eventlog_message_cache $source fmtstring $opts(langid) $eventid]} {
        set fmtstring [dict get $_eventlog_message_cache $source fmtstring $opts(langid) $eventid]
        dict incr _eventlog_message_cache __fmtstring_hits
    } else {
        dict incr _eventlog_message_cache __fmtstring_misses

        # Find the registry key if we do not have it already
        if {[dict exists $_eventlog_message_cache $source regkey]} {
            dict incr _eventlog_message_cache __regkey_hits
            set regkey [dict get $_eventlog_message_cache $source regkey]
        } else {
            set regkey [_find_eventlog_regkey $source]
            dict set _eventlog_message_cache $source regkey $regkey
            dict incr _eventlog_message_cache __regkey_misses
        }

        # Get the message file, if there is one
        if {! [catch {registry get $regkey "EventMessageFile"} path]} {
            # Try each file listed in turn
            foreach dll [split $path \;] {
                set dll [expand_environment_strings $dll]
                if {! [catch {
                    set fmtstring [format_message -module $dll -messageid $eventid -width $opts(width) -langid $opts(langid)]
                } msg]} {
                    dict set _eventlog_message_cache $source fmtstring $opts(langid) $eventid $fmtstring
                    break
                }
            }
        }
    }

    if {! [info exists fmtstring]} {
        dict incr _eventlog_message_cache __notfound

        set fmt "The message file or event definition for event id [dict get $rec -eventid] from source [dict get $rec -source] was not found. The following information was part of the event: "
        set flds [list ]
        for {set i 1} {$i <= [llength [dict get $rec -params]]} {incr i} {
            lappend flds %$i
        }
        append fmt [join $flds ", "]
        return [format_message -fmtstring $fmt  \
                    -params [dict get $rec -params] -width $opts(width)]
    }

    set msg [format_message -fmtstring $fmtstring -params [dict get $rec -params]]

    # We'd found a message from the message file and replaced the string
    # parameters. Now fill in the parameter file values if any. Note these are
    # separate from the string parameters passed in through rec(-params)

    # First check if the formatted string itself still has placeholders
    # Place holder for the parameters file are supposed to start
    # with two % chars. Unfortunately, not all apps, even Microsoft's own
    # DCOM obey this. So check for both % and %%
    set placeholder_indices [regexp -indices -all -inline {%?%\d+} $msg]
    if {[llength $placeholder_indices] == 0} {
        # No placeholders.
        return $msg
    }

    # Loop through to replace placeholders.
    set msg2 "";                # Holds result after param replacement
    set prev_end 0
    foreach placeholder $placeholder_indices {
        lassign $placeholder start end
        # Append the stuff between previous placeholder and this one
        append msg2 [string range $msg $prev_end [expr {$start-1}]]
        set repl [string range $msg $start $end]; # Default if not found
        set paramid [string trimleft $repl %];     # Skip "%"
        if {[dict exists $_eventlog_message_cache $source paramstring $opts(langid) $paramid]} {
            dict incr _eventlog_message_cache __paramstring_hits
            set repl [format_message -fmtstring [dict get $_eventlog_message_cache $source paramstring $opts(langid) $paramid] -params [dict get $rec -params]]
        } else {
            dict incr _eventlog_message_cache __paramstring_misses
            # Not in cache, need to look up
            if {![info exists paramfiles]} {
                # Construct list of parameter string files

                # TBD - cache registry key results?
                # Find the registry key if we do not have it already
                if {![info exists regkey]} {
                    if {[dict exists $_eventlog_message_cache $source regkey]} {
                        dict incr _eventlog_message_cache __regkey_hits
                        set regkey [dict get $_eventlog_message_cache $source regkey]
                    } else {
                        dict incr _eventlog_message_cache __regkey_misses
                        set regkey [_find_eventlog_regkey $source]
                        dict set _eventlog_message_cache $source regkey $regkey
                    }
                }
                set paramfiles {}
                if {! [catch {registry get $regkey "ParameterMessageFile"} path]} {
                    # Loop through every placeholder, look for the entry in the
                    # parameters file and replace it if found
                    foreach paramfile [split $path \;] {
                        lappend paramfiles [expand_environment_strings $paramfile]
                    }
                }
            }
            # Try each file listed in turn
            foreach paramfile $paramfiles {
                if {! [catch {
                    set paramstring [string trimright [format_message -module $paramfile -messageid $paramid -langid $opts(langid)] \r\n]
                } ]} {
                    # Found the replacement
                    dict set _eventlog_message_cache $source paramstring $opts(langid) $paramid $paramstring
                    set repl [format_message -fmtstring $paramstring -params [dict get $rec -params]]
                    break
                }
            }
        }
        append msg2 $repl
        set prev_end [incr end]
    }
    
    # Tack on tail after last placeholder
    append msg2 [string range $msg $prev_end end]
    return $msg2
}

# Format the category
proc twapi::eventlog_format_category {rec args} {

    array set opts [parseargs args {
        width.int
        langid.int
    } -nulldefault]

    set category [dict get $rec -category]
    if {$category == 0} {
        return ""
    }

    variable _eventlog_message_cache

    set source  [dict get $rec -source]

    # Get the category string from cache, if there is one
    if {[dict exists $_eventlog_message_cache $source category $opts(langid) $category]} {
        dict incr _eventlog_message_cache __category_hits
        set fmtstring [dict get $_eventlog_message_cache $source category $opts(langid) $category]
    } else {
        dict incr _eventlog_message_cache __category_misses

        # Find the registry key if we do not have it already
        if {[dict exists $_eventlog_message_cache $source regkey]} {
            dict incr _eventlog_message_cache __regkey_hits
            set regkey [dict get $_eventlog_message_cache $source regkey]
        } else {
            set regkey [_find_eventlog_regkey $source]
            dict set _eventlog_message_cache $source regkey $regkey
            dict incr _eventlog_message_cache __regkey_misses
        }

        if {! [catch {registry get $regkey "CategoryMessageFile"} path]} {
            # Try each file listed in turn
            foreach dll [split $path \;] {
                set dll [expand_environment_strings $dll]
                if {! [catch {
                    set fmtstring [format_message -module $dll -messageid $category -width $opts(width) -langid $opts(langid)]
                } msg]} {
                    dict set _eventlog_message_cache $source category $opts(langid) $category $fmtstring
                    break
                }
            }
        }
    }

    if {![info exists fmtstring]} {
        set fmtstring "Category $category"
        dict set _eventlog_message_cache $source category $opts(langid) $category $fmtstring
    }

    return [format_message -fmtstring $fmtstring -params [dict get $rec -params]]
}

proc twapi::eventlog_monitor_start {hevl script} {
    variable _eventlog_notification_scripts

    set hevent [lindex [CreateEvent [_make_secattr {} 0] 0 0 ""] 0]
    if {[catch {NotifyChangeEventLog $hevl $hevent} msg]} {
        CloseHandle $hevent
        error $msg $::errorInfo $::errorCode
    }

    wait_on_handle $hevent -async twapi::_eventlog_notification_handler
    set _eventlog_notification_scripts($hevent) $script

    # We do not want the application mistakenly closing the event
    # while being waited on by the thread pool. That would be a big NO-NO
    # so change the handle type so it cannot be passed to close_handle.
    return [list evl $hevent]
}

# Stop any notifications. Note these will stop even if the event log
# handle is closed but leave the event dangling.
proc twapi::eventlog_monitor_stop {hevent} {
    variable _eventlog_notification_scripts
    set hevent [lindex $hevent 1]
    if {[info exists _eventlog_notification_scripts($hevent)]} {
        unset _eventlog_notification_scripts($hevent)
        cancel_wait_on_handle $hevent
        CloseHandle $hevent
    }
}

proc twapi::_eventlog_notification_handler {hevent event} {
    variable _eventlog_notification_scripts
    if {[info exists _eventlog_notification_scripts($hevent)] &&
        $event eq "signalled"} {
        uplevel #0 $_eventlog_notification_scripts($hevent) [list [list evl $hevent]]
    }
}

# TBD - document
proc twapi::eventlog_subscribe {source} {
    set hevl [eventlog_open -source $source]
    set hevent [lindex [CreateEvent [_make_secattr {} 0] 0 0 ""] 0]
    if {[catch {NotifyChangeEventLog $hevl $hevent} msg]} {
        set erinfo $::errorInfo
        set ercode $::errorCode
        CloseHandle $hevent
        error $hsubscribe $erinfo $ercode
    }

    return [list $hevl $hevent]
}

# Utility procs

# Find the registry key corresponding the given event log source
proc twapi::_find_eventlog_regkey {source} {
    set topkey {HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Eventlog}

    # Set a default list of children to work around an issue in
    # the Tcl [registry keys] command where a ERROR_MORE_DATA is returned
    # instead of a retry with a larger buffer.
    set keys {Application Security System}
    catch {set keys [registry keys $topkey]}
    # Get all keys under this key and look for a source under that
    foreach key $keys {
        # See above Tcl issue
        set srckeys {}
        catch {set srckeys [registry keys "${topkey}\\$key"]}
        foreach srckey $srckeys {
            if {[string equal -nocase $srckey $source]} {
                return "${topkey}\\${key}\\$srckey"
            }
        }
    }

    # Default to Application - TBD
    return "${topkey}\\Application"
}

proc twapi::_eventlog_dump {source chan} {
    set hevl [eventlog_open -source $source]
    while {[llength [set events [eventlog_read $hevl]]]} {
        # print out each record
        foreach eventrec $events {
            array set event $eventrec
            set timestamp [clock format $event(-timewritten) -format "%x %X"]
            set source   $event(-source)
            set category [twapi::eventlog_format_category $eventrec -width -1]
            set message  [twapi::eventlog_format_message $eventrec -width -1]
            puts $chan "$timestamp  $source  $category  $message"
        }
    }
    eventlog_close $hevl
}




# If we are being sourced ourselves, then we need to source the remaining files.
if {[file tail [info script]] eq "eventlog.tcl"} {
    source [file join [file dirname [info script]] evt.tcl]
    source [file join [file dirname [info script]] winlog.tcl]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/evt.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
#
# Copyright (c) 2012-2014, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# Event log handling for Vista and later

namespace eval twapi {
    variable _evt;              # See _evt_init

    # System event fields in order returned by _evt_decode_event_system_fields
    twapi::record evt_system_fields  {
        -providername -providerguid -eventid -qualifiers -level -task
        -opcode -keywordmask -timecreated -eventrecordid -activityid
        -relatedactivityid -pid -tid -channel
        -computer -sid -version
    }

    proc _evt_init {} {
        variable _evt

        # Various structures that we maintain / cache for efficiency as they
        # are commonly used are kept in the _evt array with the following keys:

        # system_render_context_handle - is the handle to a rendering
        #    context for the system portion of an event
        set _evt(system_render_context_handle) [evt_render_context_system]

        # user_render_context_handle - is the handle to a rendering
        #    context for the user data portion of an event
        set _evt(user_render_context_handle) [evt_render_context_user]

        # render_buffer - is NULL or holds a pointer to the buffer used to
        #    retrieve values so does not have to be reallocated every time.
        set _evt(render_buffer) NULL

        # publisher_handles - caches publisher names to their meta information.
        #    This is a dictionary indexed with nested keys - 
        #     publisher, session, lcid. TBD - need a mechanism to clear ?
        set _evt(publisher_handles) [dict create]

        # -levelname - dict of publisher name / level number to level names
        set _evt(-levelname) {}

        # -taskname - dict of publisher name / task number to task name
        set _evt(-taskname) {}

        # -opcodename - dict of publisher name / opcode number to opcode name
        set _evt(-opcodename) {}

        # No-op the proc once init is done
        proc _evt_init {} {}
    }
}

# TBD - document
proc twapi::evt_local_session {} {
    return NULL
}

# TBD - document
proc twapi::evt_local_session? {hsess} {
    return [pointer_null? $hsess]
}

# TBD - document
proc twapi::evt_open_session {server args} {
    array set opts [parseargs args {
        user.arg
        domain.arg
        password.arg
        {authtype.arg 0}
    } -nulldefault -maxleftover 0]

    if {![string is integer -strict $opts(authtype)]} {
        set opts(authtype) [dict get {default 0 negotiate 1 kerberos 2 ntlm 3} [string tolower $opts(authtype)]]
    }

    return [EvtOpenSession 1 [list $server $opts(user) $opts(domain) $opts(password) $opts(authtype)] 0 0]
}

# TBD - document
proc twapi::evt_close_session {hsess} {
    if {![evt_local_session? $hsess]} {
        evt_close $hsess
    }
}

proc twapi::evt_channels {{hevtsess NULL}} {
    # TBD - document hevtsess
    set chnames {}
    set hevt [EvtOpenChannelEnum $hevtsess 0]
    trap {
        while {[set chname [EvtNextChannelPath $hevt]] ne ""} {
            lappend chnames $chname
        }
    } finally {
        evt_close $hevt
    }

    return $chnames
}

proc twapi::evt_clear_log {chanpath args} {
    # TBD - document -session
    array set opts [parseargs args {
        {session.arg NULL}
        {backup.arg ""}
    } -maxleftover 0]

    return [EvtClearLog $opts(session) $chanpath [_evt_normalize_path $opts(backup)] 0]
}

# TBD - document
proc twapi::evt_archive_exported_log {logpath args} {
    array set opts [parseargs args {
        {session.arg NULL}
        {lcid.int 0}
    } -maxleftover 0]

    return [EvtArchiveExportedLog $opts(session) [_evt_normalize_path $logpath] $opts(lcid) 0]
}

proc twapi::evt_export_log {outfile args} {
    # TBD - document -session
    array set opts [parseargs args {
        {session.arg NULL}
        file.arg
        channel.arg
        {query.arg *}
        {ignorequeryerrors 0 0x1000}
    } -maxleftover 0]

    if {([info exists opts(file)] && [info exists opts(channel)]) ||
        ! ([info exists opts(file)] || [info exists opts(channel)])} {
        error "Exactly one of -file or -channel must be specified."
    }

    if {[info exists opts(file)]} {
        set path [_evt_normalize_path $opts(file)]
        incr opts(ignorequeryerrors) 2
    } else {
        set path $opts(channel)
        incr opts(ignorequeryerrors) 1
    }

    return [EvtExportLog $opts(session) $path $opts(query) [_evt_normalize_path $outfile] $opts(ignorequeryerrors)]
}

# TBD - document
proc twapi::evt_create_bookmark {{mark ""}} {
    return [EvtCreateBookmark $mark]
}

# TBD - document
proc twapi::evt_render_context_xpaths {xpaths} {
    return [EvtCreateRenderContext $xpaths 0]
}

# TBD - document
proc twapi::evt_render_context_system {} {
    return [EvtCreateRenderContext {} 1]
}

# TBD - document
proc twapi::evt_render_context_user {} {
    return [EvtCreateRenderContext {} 2]
}

# TBD - document
proc twapi::evt_open_channel_config {chanpath args} {
    array set opts [parseargs args {
        {session.arg NULL}
    } -maxleftover 0]

    return [EvtOpenChannelConfig $opts(session) $chanpath 0]
}

# TBD - document
proc twapi::evt_get_channel_config {hevt args} {
    set result {}
    foreach opt $args {
        lappend result $opt \
            [EvtGetChannelConfigProperty $hevt \
                 [_evt_map_channel_config_property $hevt $propid]]
    }
    return $result
}

# TBD - document
proc twapi::evt_set_channel_config {hevt propid val} {
    return [EvtSetChannelConfigProperty $hevt [_evt_map_channel_config_property $propid 0 $val]]
}


# TBD - document
proc twapi::_evt_map_channel_config_property {propid} {
    if {[string is integer -strict $propid]} {
        return $propid
    }
    
    # Note: values are from winevt.h, Win7 SDK has typos for last few
    return [dict get {
        -enabled                  0
        -isolation                1
        -type                     2
        -owningpublisher          3
        -classiceventlog          4
        -access                   5
        -loggingretention         6
        -loggingautobackup        7
        -loggingmaxsize           8
        -logginglogfilepath       9
        -publishinglevel          10
        -publishingkeywords       11
        -publishingcontrolguid    12
        -publishingbuffersize     13
        -publishingminbuffers     14
        -publishingmaxbuffers     15
        -publishinglatency        16
        -publishingclocktype      17
        -publishingsidtype        18
        -publisherlist            19
        -publishingfilemax        20
    } $propid]
}

# TBD - document
proc twapi::evt_event_info {hevt args} {
    set result {}
    foreach opt $args {
        lappend result $opt [EvtGetEventInfo $hevt \
                                 [dict get {-queryids 0 -path 1} $opt]]
    }
    return $result
}


# TBD - document
proc twapi::evt_event_metadata_property {hevt args} {
    set result {}
    foreach opt $args {
        lappend result $opt \
            [EvtGetEventMetadataProperty $hevt \
                 [dict get {
                     -id 0 -version 1 -channel 2 -level 3
                     -opcode 4 -task 5 -keyword 6 -messageid 7 -template 8
                 } $opt]]
    }
    return $result
}


# TBD - document
proc twapi::evt_open_log_info {args} {
    array set opts [parseargs args {
        {session.arg NULL}
        file.arg
        channel.arg
    } -maxleftover 0]

    if {([info exists opts(file)] && [info exists opts(channel)]) ||
        ! ([info exists opts(file)] || [info exists opts(channel)])} {
        error "Exactly one of -file or -channel must be specified."
    }
    
    if {[info exists opts(file)]} {
        set path [_evt_normalize_path $opts(file)]
        set flags 0x2
    } else {
        set path $opts(channel)
        set flags 0x1
    }

    return [EvtOpenLog $opts(session) $path $flags]
}

# TBD - document
proc twapi::evt_log_info {hevt args} {
    set result {}
    foreach opt $args {
        lappend result $opt  [EvtGetLogInfo $hevt [dict get {
            -creationtime 0 -lastaccesstime 1 -lastwritetime 2
            -filesize 3 -attributes 4 -numberoflogrecords 5
            -oldestrecordnumber 6 -full 7
        } $opt]]
    }
    return $result
}

# TBD - document
proc twapi::evt_publisher_metadata_property {hpub args} {
    set result {}
    foreach opt $args {
        set val [EvtGetPublisherMetadataProperty $hpub [dict get {
            -publisherguid 0  -resourcefilepath 1 -parameterfilepath 2
            -messagefilepath 3 -helplink 4 -publishermessageid 5
            -channelreferences 6 -levels 12 -tasks 16
            -opcodes 21 -keywords 25
        } $opt] 0]
        if {$opt ni {-channelreferences -levels -tasks -opcodes -keywords}} {
            lappend result $opt $val
            continue
        }
        set n [EvtGetObjectArraySize $val]
        set val2 {}
        for {set i 0} {$i < $n} {incr i} {
            set rec {}
            foreach {opt2 iopt} [dict get {
                -channelreferences { -channelreferencepath 7
                    -channelreferenceindex 8 -channelreferenceid 9
                    -channelreferenceflags 10 -channelreferencemessageid 11}
                -levels { -levelname 13 -levelvalue 14 -levelmessageid 15 }
                -tasks { -taskname 17 -taskeventguid 18 -taskvalue 19
                    -taskmessageid 20}
                -opcodes {-opcodename 22 -opcodevalue 23 -opcodemessageid 24}
                -keywords {-keywordname 26 -keywordvalue 27
                    -keywordmessageid 28}
            } $opt] {
                lappend rec $opt2 [EvtGetObjectArrayProperty $val $iopt $i]
            }
            lappend val2 $rec
        }

        evt_close $val
        lappend result $opt $val2
    }
    return $result
}

# TBD - document
proc twapi::evt_query_info {hq args} {
    set result {}
    foreach opt $args {
        lappend result $opt  [EvtGetQueryInfo $hq [dict get {
            -names 1 statuses 2
        } $opt]]
    }
    return $result
}

# TBD - document
proc twapi::evt_object_array_size {hevt} {
    return [EvtGetObjectArraySize $hevt]
}

# TBD - document
proc twapi::evt_object_array_property {hevt index args} {
    set result {}

    foreach opt $args {
        lappend result $opt \
            [EvtGetObjectArrayProperty $hevt [dict get {
                -channelreferencepath 7
                -channelreferenceindex 8 -channelreferenceid 9
                -channelreferenceflags 10 -channelreferencemessageid 11
                -levelname 13 -levelvalue 14 -levelmessageid 15
                -taskname 17 -taskeventguid 18 -taskvalue 19
                -taskmessageid 20 -opcodename 22
                -opcodevalue 23 -opcodemessageid 24
                -keywordname 26 -keywordvalue 27 -keywordmessageid 28
            }] $index]
    }
    return $result
}

proc twapi::evt_publishers {{hsess NULL}} {
    set pubs {}
    set hevt [EvtOpenPublisherEnum $hsess 0]
    trap {
        while {[set pub [EvtNextPublisherId $hevt]] ne ""} {
            lappend pubs $pub
        }
    } finally {
        evt_close $hevt
    }

    return $pubs
}

# TBD - document
proc twapi::evt_open_publisher_metadata {pub args} {
    array set opts [parseargs args {
        {session.arg NULL}
        logfile.arg
        lcid.int
    } -nulldefault -maxleftover 0]

    return [EvtOpenPublisherMetadata $opts(session) $pub $opts(logfile) $opts(lcid) 0]
}

# TBD - document
proc twapi::evt_publisher_events_metadata {hpub args} {
    set henum [EvtOpenEventMetadataEnum $hpub]

    # It is faster to build a list and then have Tcl shimmer to a dict when
    # required
    set meta {}
    trap {
        while {[set hmeta [EvtNextEventMetadata $henum 0]] ne ""} {
            lappend meta [evt_event_metadata_property $hmeta {*}$args]
            evt_close $hmeta
        }
    } finally {
        evt_close $henum
    }
    
    return $meta
}

proc twapi::evt_query {args} {
    array set opts [parseargs args {
        {session.arg NULL}
        file.arg
        channel.arg
        {query.arg *}
        {ignorequeryerrors 0 0x1000}
        {direction.sym forward {forward 0x100 reverse 0x200 backward 0x200}}
    } -maxleftover 0]

    if {([info exists opts(file)] && [info exists opts(channel)]) ||
        ! ([info exists opts(file)] || [info exists opts(channel)])} {
        error "Exactly one of -file or -channel must be specified."
    }
    
    set flags $opts(ignorequeryerrors)
    incr flags $opts(direction)

    if {[info exists opts(file)]} {
        set path [_evt_normalize_path $opts(file)]
        incr flags 0x2
    } else {
        set path $opts(channel)
        incr flags 0x1
    }

    return [EvtQuery $opts(session) $path $opts(query) $flags]
}

proc twapi::evt_next {hresultset args} {
    array set opts [parseargs args {
        {timeout.int -1}
        {count.int 1}
        {status.arg}
    } -maxleftover 0]

    if {[info exists opts(status)]} {
        upvar 1 $opts(status) status
        return [EvtNext $hresultset $opts(count) $opts(timeout) 0 status]
    } else {
        return [EvtNext $hresultset $opts(count) $opts(timeout) 0]
    }
}

twapi::proc* twapi::_evt_decode_event_system_fields {hevt} {
    _evt_init
} {
    variable _evt
    set _evt(render_buffer) [Twapi_EvtRenderValues $_evt(system_render_context_handle) $hevt $_evt(render_buffer)]
    set rec [Twapi_ExtractEVT_RENDER_VALUES $_evt(render_buffer)]
    return [evt_system_fields set $rec \
                -providername [atomize [evt_system_fields -providername $rec]] \
                -providerguid [atomize [evt_system_fields -providerguid $rec]] \
                -channel [atomize [evt_system_fields -channel $rec]] \
                -computer [atomize [evt_system_fields -computer $rec]]]
}

# TBD - document. Returns a list of user data values
twapi::proc* twapi::evt_decode_event_userdata {hevt} {
    _evt_init
} {
    variable _evt
    set _evt(render_buffer) [Twapi_EvtRenderValues $_evt(user_render_context_handle) $hevt $_evt(render_buffer)]
    return [Twapi_ExtractEVT_RENDER_VALUES $_evt(render_buffer)]
}

twapi::proc* twapi::evt_decode_events {hevts args} {
    _evt_init
} {
    variable _evt

    array set opts [parseargs args {
        {values.arg NULL}
        {session.arg NULL}
        {logfile.arg ""}
        {lcid.int 0}
        ignorestring.arg
        message
        levelname
        taskname
        opcodename
        keywords
        xml
    } -ignoreunknown -hyphenated]
        
    # SAME ORDER AS _evt_decode_event_system_fields
    set decoded_fields [evt_system_fields]
    set decoded_events {}
    
    # ORDER MUST BE SAME AS order in which values are appended below
    foreach opt {-levelname -taskname -opcodename -keywords -xml -message} {
        if {$opts($opt)} {
            lappend decoded_fields $opt
        }
    }

    foreach hevt $hevts {
        set decoded [_evt_decode_event_system_fields $hevt]
        # Get publisher from hevt
        set publisher [evt_system_fields -providername $decoded]

        if {! [dict exists $_evt(publisher_handles) $publisher $opts(-session) $opts(-lcid)]} {
            if {[catch {
                dict set _evt(publisher_handles) $publisher $opts(-session) $opts(-lcid) [EvtOpenPublisherMetadata $opts(-session) $publisher $opts(-logfile) $opts(-lcid) 0]
            }]} {
                # TBD - debug log
                dict set _evt(publisher_handles) $publisher $opts(-session) $opts(-lcid) NULL
            }
        }
        set hpub [dict get $_evt(publisher_handles) $publisher $opts(-session) $opts(-lcid)]

        # See if cached values are present for -levelname -taskname
        # and -opcodename. TBD - can -keywords be added to this ?
        foreach {intopt opt callflag} {-level -levelname 2 -task -taskname 3 -opcode -opcodename 4} {
            if {$opts($opt)} {
                set ival [evt_system_fields $intopt $decoded]
                if {[dict exists $_evt($opt) $publisher $ival]} {
                    lappend decoded [dict get $_evt($opt) $publisher $ival]
                } else {
                    # Not cached. Look it up. Value of 0 -> null so
                    # just use ignorestring if specified.
                    if {$ival == 0 && [info exists opts(-ignorestring)]} {
                        set optval $opts(-ignorestring)
                    } else {
                        if {[info exists opts(-ignorestring)]} {
                            if {[EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag optval]} {
                                dict set _evt($opt) $publisher $ival $optval
                            } else {
                                # Note result not cached if not found since
                                # ignorestring may be different on every call
                                set optval $opts(-ignorestring)
                            }
                        } else {
                            # -ignorestring not specified so
                            # will raise error if not found
                            set optval [EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag]
                            dict set _evt($opt) $publisher $ival [atomize $optval]
                        }
                    }
                    lappend decoded $optval
                }
            }
        }

        # Non-cached fields
        # ORDER MUST BE SAME AS decoded_fields ABOVE
        foreach {opt callflag} {
            -keywords 5
            -xml 9
        } {
            if {$opts($opt)} {
                if {[info exists opts(-ignorestring)]} {
                    if {! [EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag optval]} {
                        set optval $opts(-ignorestring)
                    }
                } else {
                    set optval [EvtFormatMessage $hpub $hevt 0 $opts(-values) $callflag]
                }
                lappend decoded $optval
            }
        }

        # We treat -message differently because on failure we want
        # to extract the user data. -ignorestring is not used for this
        # unless user data extraction also fails
        if {$opts(-message)} {
            if {[EvtFormatMessage $hpub $hevt 0 $opts(-values) 1 message]} {
                lappend decoded $message
            } else {
                # TBD - make sure we have a test for this case.
                # TBD - log
                if {[catch {
                    lappend decoded "Message for event could not be found. Event contained user data: [join [evt_decode_event_userdata $hevt] ,]"
                } message]} {
                    if {[info exists opts(-ignorestring)]} {
                        lappend decoded $opts(-ignorestring)
                    } else {
                        error $message
                    }
                }
            }
        }
        
        lappend decoded_events $decoded
    }

    return [list $decoded_fields $decoded_events]
}

proc twapi::evt_decode_event {hevt args} {
    return [recordarray index [evt_decode_events [list $hevt] {*}$args] 0 -format dict]
}

# TBD - document
proc twapi::evt_format_publisher_message {hpub msgid args} {

    array set opts [parseargs args {
        {values.arg NULL}
    } -maxleftover 0]
        
    return [EvtFormatMessage $hpub NULL $msgid $opts(values) 8]
}

# TBD - document
# Where is this used?
proc twapi::evt_free_EVT_VARIANT_ARRAY {p} {
    evt_free $p
}

# TBD - document
# Where is this used?
proc twapi::evt_free_EVT_RENDER_VALUES {p} {
    evt_free $p
}

# TBD - document
proc twapi::evt_seek {hresults pos args} {
    array set opts [parseargs args {
        {origin.arg first {first last current}}
        bookmark.arg
        {strict 0 0x10000}
    } -maxleftover 0]

    if {[info exists opts(bookmark)]} {
        set flags 4
    } else {
        set flags [lsearch -exact {first last current} $opts(origin)]
        incr flags;             # 1 -> first, 2 -> last, 3 -> current
        set opts(bookmark) NULL
    }
        
    incr flags $opts(strict)

    EvtSeek $hresults $pos $opts(bookmark) 0 $flags
}

proc twapi::evt_subscribe {path args} {
    # TBD - document -session and -bookmark and -strict
    array set opts [parseargs args {
        {session.arg NULL}
        {query.arg *}
        bookmark.arg
        includeexisting
        {ignorequeryerrors 0 0x1000}
        {strict 0 0x10000}
    } -maxleftover 0]

    set flags [expr {$opts(ignorequeryerrors) | $opts(strict)}]
    if {[info exists opts(bookmark)]} {
        set flags [expr {$flags | 3}]
        set bookmark $opts(origin)
    } else {
        set bookmark NULL
        if {$opts(includeexisting)} {
            set flags [expr {$flags | 2}]
        } else {
            set flags [expr {$flags | 1}]
        }
    }

    set hevent [lindex [CreateEvent [_make_secattr {} 0] 0 0 ""] 0]
    if {[catch {
        EvtSubscribe $opts(session) $hevent $path $opts(query) $bookmark $flags
    } hsubscribe]} {
        set erinfo $::errorInfo
        set ercode $::errorCode
        CloseHandle $hevent
        error $hsubscribe $erinfo $ercode
    }

    return [list $hsubscribe $hevent]
}

proc twapi::_evt_normalize_path {path} {
    # Do not want to rely on [file normalize] returning "" for ""
    if {$path eq ""} {
        return ""
    } else {
        return [file nativename [file normalize $path]]
    }
}

proc twapi::_evt_dump {args} {
    array set opts [parseargs args {
        {outfd.arg stdout}
        count.int
    } -ignoreunknown]

    set hq [evt_query {*}$args]
    trap {
        while {[llength [set hevts [evt_next $hq]]]} {
            trap {
                foreach ev [recordarray getlist [evt_decode_events $hevts -message -ignorestring None.] -format dict] {
                    if {[info exists opts(count)] &&
                        [incr opts(count) -1] < 0} {
                        return
                    }
                    puts $opts(outfd) "[dict get $ev -timecreated] [dict get $ev -eventrecordid] [dict get $ev -providername]: [dict get $ev -eventrecordid] [dict get $ev -message]"
                }
            } finally {
                evt_close {*}$hevts
            }
        }
    } finally {
        evt_close $hq
    }
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<




























































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































































Deleted winlibs/twapi/handle.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
#
# Copyright (c) 2010, Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

namespace eval twapi {
    # Array maps handles we are waiting on to the ids of the registered waits
    variable _wait_handle_ids
    # Array maps id of registered wait to the corresponding callback scripts
    variable _wait_handle_scripts
    
}

proc twapi::cast_handle {h type} {
    # TBD - should this use pointer_from_address:
    #    return [pointer_from_address [address_from_pointer $h] $type]
    return [list [lindex $h 0] $type]
}

proc twapi::close_handle {h} {

    # Cancel waits on the handle, if any
    cancel_wait_on_handle $h
    
    # Then close it
    CloseHandle $h
}

# Close multiple handles. In case of errors, collects them but keeps
# closing remaining handles and only raises the error at the end.
proc twapi::close_handles {args} {
    # The original definition for this was broken in that it would
    # gracefully accept non list parameters as a list of one. In 3.0
    # the handle format has changed so this does not happen
    # naturally. We have to try and decipher whether it is a list
    # of handles or a single handle.

    foreach arg $args {
        if {[pointer? $arg]} {
            # Looks like a single handle
            if {[catch {close_handle $arg} msg]} {
                set erinfo $::errorInfo
                set ercode $::errorCode
                set ermsg $msg
            }
        } else {
            # Assume a list of handles
            foreach h $arg {
                if {[catch {close_handle $h} msg]} {
                    set erinfo $::errorInfo
                    set ercode $::errorCode
                    set ermsg $msg
                }
            }
        }
    }

    if {[info exists erinfo]} {
        error $msg $erinfo $ercode
    }
}

#
# Wait on a handle
proc twapi::wait_on_handle {hwait args} {
    variable _wait_handle_ids
    variable _wait_handle_scripts

    # When we are invoked from callback, handle is always typed as HANDLE
    # so convert it so lookups succeed
    set h [cast_handle $hwait HANDLE]

    # 0x00000008 ->   # WT_EXECUTEONCEONLY
    array set opts [parseargs args {
        {wait.int -1}
        async.arg
        {executeonce.bool false 0x00000008}
    }]

    if {![info exists opts(async)]} {
        if {[info exists _wait_handle_ids($h)]} {
            error "Attempt to synchronously wait on handle that is registered for an asynchronous wait."
        }

        set ret [WaitForSingleObject $h $opts(wait)]
        if {$ret == 0x80} {
            return abandoned
        } elseif {$ret == 0} {
            return signalled
        } elseif {$ret == 0x102} {
            return timeout
        } else {
            error "Unexpected value $ret returned from WaitForSingleObject"
        }
    }

    # async option specified

    # Do not wait on manual reset events as cpu will spin continuously
    # queueing events
    if {[pointer? $hwait HANDLE_MANUALRESETEVENT] &&
        ! $opts(executeonce)
    } {
        error "A handle to a manual reset event cannot be waited on asynchronously unless -executeonce is specified."
    }

    # If handle already registered, cancel previous registration.
    if {[info exists _wait_handle_ids($h)]} {
        cancel_wait_on_handle $h
    }


    set id [Twapi_RegisterWaitOnHandle $h $opts(wait) $opts(executeonce)]

    # Set now that successfully registered
    set _wait_handle_scripts($id) $opts(async)
    set _wait_handle_ids($h) $id

    return
}

#
# Cancel an async wait on a handle
proc twapi::cancel_wait_on_handle {h} {
    variable _wait_handle_ids
    variable _wait_handle_scripts

    if {[info exists _wait_handle_ids($h)]} {
        Twapi_UnregisterWaitOnHandle $_wait_handle_ids($h)
        unset _wait_handle_scripts($_wait_handle_ids($h))
        unset _wait_handle_ids($h)
    }
}

#
# Called from C when a handle is signalled or times out
proc twapi::_wait_handler {id h event} {
    variable _wait_handle_ids
    variable _wait_handle_scripts

    # We ignore the following stale event cases -
    #  - _wait_handle_ids($h) does not exist : the wait was canceled while
    #    and event was queued
    #  - _wait_handle_ids($h) exists but is different from $id - same
    #    as prior case, except that a new wait has since been initiated
    #    on the same handle value (which might have be for a different
    #    resource

    if {[info exists _wait_handle_ids($h)] &&
        $_wait_handle_ids($h) == $id} {
        uplevel #0 [linsert $_wait_handle_scripts($id) end $h $event]
    }

    return
}

# Get the handle for a Tcl channel
proc twapi::get_tcl_channel_handle {chan direction} {
    set direction [expr {[string equal $direction "write"] ? 1 : 0}]
    return [Tcl_GetChannelHandle $chan $direction]
}

# Duplicate a OS handle
proc twapi::duplicate_handle {h args} {
    variable my_process_handle

    array set opts [parseargs args {
        sourcepid.int
        targetpid.int
        access.arg
        inherit
        closesource
    } -maxleftover 0]

    # Assume source and target processes are us
    set source_ph $my_process_handle
    set target_ph $my_process_handle

    if {[string is wideinteger $h]} {
        set h [pointer_from_address $h HANDLE]
    }

    trap {
        set me [pid]
        # If source pid specified and is not us, get a handle to the process
        if {[info exists opts(sourcepid)] && $opts(sourcepid) != $me} {
            set source_ph [get_process_handle $opts(sourcepid) -access process_dup_handle]
        }

        # Ditto for target process...
        if {[info exists opts(targetpid)] && $opts(targetpid) != $me} {
            set target_ph [get_process_handle $opts(targetpid) -access process_dup_handle]
        }

        # Do we want to close the original handle (DUPLICATE_CLOSE_SOURCE)
        set flags [expr {$opts(closesource) ? 0x1: 0}]

        if {[info exists opts(access)]} {
            set access [_access_rights_to_mask $opts(access)]
        } else {
            # If no desired access is indicated, we want the same access as
            # the original handle
            set access 0
            set flags [expr {$flags | 0x2}]; # DUPLICATE_SAME_ACCESS
        }


        set dup [DuplicateHandle $source_ph $h $target_ph $access $opts(inherit) $flags]

        # IF targetpid specified, return handle else literal
        # (even if targetpid is us)
        if {[info exists opts(targetpid)]} {
            set dup [pointer_to_address $dup]
        }
    } finally {
        if {$source_ph != $my_process_handle} {
            CloseHandle $source_ph
        }
        if {$target_ph != $my_process_handle} {
            CloseHandle $source_ph
        }
    }

    return $dup
}

proc twapi::set_handle_inheritance {h inherit} {
    # 1 -> HANDLE_FLAG_INHERIT
    SetHandleInformation $h 0x1 [expr {$inherit ? 1 : 0}]
}

proc twapi::get_handle_inheritance {h} {
    # 1 -> HANDLE_FLAG_INHERIT
    return [expr {[GetHandleInformation $h] & 1}]
}
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
























































































































































































































































































































































































































































































Deleted winlibs/twapi/input.tcl.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
#
# Copyright (c) 2012 Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

package require twapi_ui;       # SetCursorPos etc.

# Enable window input
proc twapi::enable_window_input {hwin} {
    return [expr {[EnableWindow $hwin 1] != 0}]
}

# Disable window input
proc twapi::disable_window_input {hwin} {
    return [expr {[EnableWindow $hwin 0] != 0}]
}

# CHeck if window input is enabled
proc twapi::window_input_enabled {hwin} {
    return [IsWindowEnabled $hwin]
}

# Simulate user input
proc twapi::send_input {inputlist} {
    array set input_defs {
        MOUSEEVENTF_MOVE        0x0001
        MOUSEEVENTF_LEFTDOWN    0x0002
        MOUSEEVENTF_LEFTUP      0x0004
        MOUSEEVENTF_RIGHTDOWN   0x0008
        MOUSEEVENTF_RIGHTUP     0x0010
        MOUSEEVENTF_MIDDLEDOWN  0x0020
        MOUSEEVENTF_MIDDLEUP    0x0040
        MOUSEEVENTF_XDOWN       0x0080
        MOUSEEVENTF_XUP         0x0100
        MOUSEEVENTF_WHEEL       0x0800
        MOUSEEVENTF_VIRTUALDESK 0x4000
        MOUSEEVENTF_ABSOLUTE    0x8000
        
        KEYEVENTF_EXTENDEDKEY 0x0001
        KEYEVENTF_KEYUP       0x0002
        KEYEVENTF_UNICODE     0x0004
        KEYEVENTF_SCANCODE    0x0008

        XBUTTON1      0x0001
        XBUTTON2      0x0002
    }

    set inputs [list ]
    foreach input $inputlist {
        if {[string equal [lindex $input 0] "mouse"]} {
            lassign $input mouse xpos ypos
            set mouseopts [lrange $input 3 end]
            array unset opts
            array set opts [parseargs mouseopts {
                relative moved
                ldown lup rdown rup mdown mup x1down x1up x2down x2up
                wheel.int
            }]
            set flags 0
            if {! $opts(relative)} {
                set flags $input_defs(MOUSEEVENTF_ABSOLUTE)
            }

            if {[info exists opts(wheel)]} {
                if {($opts(x1down) || $opts(x1up) || $opts(x2down) || $opts(x2up))} {
                    error "The -wheel input event attribute may not be specified with -x1up, -x1down, -x2up or -x2down events"
                }
                set mousedata $opts(wheel)
                set flags $input_defs(MOUSEEVENTF_WHEEL)
            } else {
                if {$opts(x1down) || $opts(x1up)} {
                    if {$opts(x2down) || $opts(x2up)} {
                        error "The -x1down, -x1up mouse input attributes are mutually exclusive with -x2down, -x2up attribu