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
Deleted winlibs/tdom/pkgIndex.tcl.
1 -package ifneeded tdom 0.8.3 "load [list [file join $dir tdom083.dll]]; source [list [file join $dir tdom.tcl]]"
Deleted winlibs/tdom/tdom.tcl.
1 -#---------------------------------------------------------------------------- 2 -# Copyright (c) 1999 Jochen Loewer (loewerj@hotmail.com) 3 -#---------------------------------------------------------------------------- 4 -# 5 -# $Id$ 6 -# 7 -# 8 -# The higher level functions of tDOM written in plain Tcl. 9 -# 10 -# 11 -# The contents of this file are subject to the Mozilla Public License 12 -# Version 1.1 (the "License"); you may not use this file except in 13 -# compliance with the License. You may obtain a copy of the License at 14 -# http://www.mozilla.org/MPL/ 15 -# 16 -# Software distributed under the License is distributed on an "AS IS" 17 -# basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the 18 -# License for the specific language governing rights and limitations 19 -# under the License. 20 -# 21 -# The Original Code is tDOM. 22 -# 23 -# The Initial Developer of the Original Code is Jochen Loewer 24 -# Portions created by Jochen Loewer are Copyright (C) 1998, 1999 25 -# Jochen Loewer. All Rights Reserved. 26 -# 27 -# Contributor(s): 28 -# Rolf Ade (rolf@pointsman.de): 'fake' nodelists/live childNodes 29 -# 30 -# written by Jochen Loewer 31 -# April, 1999 32 -# 33 -#---------------------------------------------------------------------------- 34 - 35 -package require tdom 36 - 37 -#---------------------------------------------------------------------------- 38 -# setup namespaces for additional Tcl level methods, etc. 39 -# 40 -#---------------------------------------------------------------------------- 41 -namespace eval ::dom { 42 - namespace eval domDoc { 43 - } 44 - namespace eval domNode { 45 - } 46 - namespace eval DOMImplementation { 47 - } 48 - namespace eval xpathFunc { 49 - } 50 - namespace eval xpathFuncHelper { 51 - } 52 -} 53 - 54 -namespace eval ::tDOM { 55 - variable extRefHandlerDebug 0 56 - variable useForeignDTD "" 57 - 58 - namespace export xmlOpenFile xmlReadFile extRefHandler baseURL 59 -} 60 - 61 -#---------------------------------------------------------------------------- 62 -# hasFeature (DOMImplementation method) 63 -# 64 -# 65 -# @in url the URL, where to get the XML document 66 -# 67 -# @return document object 68 -# @exception XML parse errors, ... 69 -# 70 -#---------------------------------------------------------------------------- 71 -proc ::dom::DOMImplementation::hasFeature { dom feature {version ""} } { 72 - 73 - switch $feature { 74 - xml - 75 - XML { 76 - if {($version == "") || ($version == "1.0")} { 77 - return 1 78 - } 79 - } 80 - } 81 - return 0 82 - 83 -} 84 - 85 -#---------------------------------------------------------------------------- 86 -# load (DOMImplementation method) 87 -# 88 -# requests a XML document via http using the given URL and 89 -# builds up a DOM tree in memory returning the document object 90 -# 91 -# 92 -# @in url the URL, where to get the XML document 93 -# 94 -# @return document object 95 -# @exception XML parse errors, ... 96 -# 97 -#---------------------------------------------------------------------------- 98 -proc ::dom::DOMImplementation::load { dom url } { 99 - 100 - error "Sorry, load method not implemented yet!" 101 - 102 -} 103 - 104 -#---------------------------------------------------------------------------- 105 -# isa (docDoc method, for [incr tcl] compatibility) 106 -# 107 -# 108 -# @in className 109 -# 110 -# @return 1 iff inherits from the given class 111 -# 112 -#---------------------------------------------------------------------------- 113 -proc ::dom::domDoc::isa { doc className } { 114 - 115 - if {$className == "domDoc"} { 116 - return 1 117 - } 118 - return 0 119 -} 120 - 121 -#---------------------------------------------------------------------------- 122 -# info (domDoc method, for [incr tcl] compatibility) 123 -# 124 -# 125 -# @in subcommand 126 -# @in args 127 -# 128 -#---------------------------------------------------------------------------- 129 -proc ::dom::domDoc::info { doc subcommand args } { 130 - 131 - switch $subcommand { 132 - class { 133 - return "domDoc" 134 - } 135 - inherit { 136 - return "" 137 - } 138 - heritage { 139 - return "domDoc {}" 140 - } 141 - default { 142 - error "domDoc::info subcommand $subcommand not yet implemented!" 143 - } 144 - } 145 -} 146 - 147 -#---------------------------------------------------------------------------- 148 -# importNode (domDoc method) 149 -# 150 -# Document Object Model (Core) Level 2 method 151 -# 152 -# 153 -# @in subcommand 154 -# @in args 155 -# 156 -#---------------------------------------------------------------------------- 157 -proc ::dom::domDoc::importNode { doc importedNode deep } { 158 - 159 - if {$deep || ($deep == "-deep")} { 160 - set node [$importedNode cloneNode -deep] 161 - } else { 162 - set node [$importedNode cloneNode] 163 - } 164 - return $node 165 -} 166 - 167 -#---------------------------------------------------------------------------- 168 -# isa (domNode method, for [incr tcl] compatibility) 169 -# 170 -# 171 -# @in className 172 -# 173 -# @return 1 iff inherits from the given class 174 -# 175 -#---------------------------------------------------------------------------- 176 -proc ::dom::domNode::isa { doc className } { 177 - 178 - if {$className == "domNode"} { 179 - return 1 180 - } 181 - return 0 182 -} 183 - 184 -#---------------------------------------------------------------------------- 185 -# info (domNode method, for [incr tcl] compatibility) 186 -# 187 -# 188 -# @in subcommand 189 -# @in args 190 -# 191 -#---------------------------------------------------------------------------- 192 -proc ::dom::domNode::info { doc subcommand args } { 193 - 194 - switch $subcommand { 195 - class { 196 - return "domNode" 197 - } 198 - inherit { 199 - return "" 200 - } 201 - heritage { 202 - return "domNode {}" 203 - } 204 - default { 205 - error "domNode::info subcommand $subcommand not yet implemented!" 206 - } 207 - } 208 -} 209 - 210 -#---------------------------------------------------------------------------- 211 -# isWithin (domNode method) 212 -# 213 -# tests, whether a node object is nested below another tag 214 -# 215 -# 216 -# @in tagName the nodeName of an elment node 217 -# 218 -# @return 1 iff node is nested below a element with nodeName tagName 219 -# 0 otherwise 220 -# 221 -#---------------------------------------------------------------------------- 222 -proc ::dom::domNode::isWithin { node tagName } { 223 - 224 - while {[$node parentNode] != ""} { 225 - set node [$node parentNode] 226 - if {[$node nodeName] == $tagName} { 227 - return 1 228 - } 229 - } 230 - return 0 231 -} 232 - 233 -#---------------------------------------------------------------------------- 234 -# tagName (domNode method) 235 -# 236 -# same a nodeName for element interface 237 -# 238 -#---------------------------------------------------------------------------- 239 -proc ::dom::domNode::tagName { node } { 240 - 241 - if {[$node nodeType] == "ELEMENT_NODE"} { 242 - return [$node nodeName] 243 - } 244 - return -code error "NOT_SUPPORTED_ERR not an element!" 245 -} 246 - 247 -#---------------------------------------------------------------------------- 248 -# simpleTranslate (domNode method) 249 -# 250 -# applies simple translation rules similar to Cost's simple 251 -# translations to a node 252 -# 253 -# 254 -# @in output_var 255 -# @in trans_specs 256 -# 257 -#---------------------------------------------------------------------------- 258 -proc ::dom::domNode::simpleTranslate { node output_var trans_specs } { 259 - 260 - upvar $output_var output 261 - 262 - if {[$node nodeType] == "TEXT_NODE"} { 263 - append output [cgiQuote [$node nodeValue]] 264 - return 265 - } 266 - set found 0 267 - 268 - foreach {match action} $trans_specs { 269 - 270 - if {[catch { 271 - if {!$found && ([$node selectNode self::$match] != "") } { 272 - set found 1 273 - } 274 - } err]} { 275 - if {![string match "NodeSet expected for parent axis!" $err]} { 276 - error $err 277 - } 278 - } 279 - if {$found && ($action != "-")} { 280 - set stop 0 281 - foreach {type value} $action { 282 - switch $type { 283 - prefix { append output [subst $value] } 284 - tag { append output <$value> } 285 - start { append output [eval $value] } 286 - stop { set stop 1 } 287 - } 288 - } 289 - if {!$stop} { 290 - foreach child [$node childNodes] { 291 - simpleTranslate $child output $trans_specs 292 - } 293 - } 294 - foreach {type value} $action { 295 - switch $type { 296 - suffix { append output [subst $value] } 297 - end { append output [eval $value] } 298 - tag { append output </$value> } 299 - } 300 - } 301 - return 302 - } 303 - } 304 - foreach child [$node childNodes] { 305 - simpleTranslate $child output $trans_specs 306 - } 307 -} 308 - 309 -#---------------------------------------------------------------------------- 310 -# a DOM conformant 'live' childNodes 311 -# 312 -# @return a 'nodelist' object (it is just the normal node) 313 -# 314 -#---------------------------------------------------------------------------- 315 -proc ::dom::domNode::childNodesLive { node } { 316 - 317 - return $node 318 -} 319 - 320 -#---------------------------------------------------------------------------- 321 -# item method on a 'nodelist' object 322 -# 323 -# @return a 'nodelist' object (it is just a normal 324 -# 325 -#---------------------------------------------------------------------------- 326 -proc ::dom::domNode::item { nodeListNode index } { 327 - 328 - return [lindex [$nodeListNode childNodes] $index] 329 -} 330 - 331 -#---------------------------------------------------------------------------- 332 -# length method on a 'nodelist' object 333 -# 334 -# @return a 'nodelist' object (it is just a normal 335 -# 336 -#---------------------------------------------------------------------------- 337 -proc ::dom::domNode::length { nodeListNode } { 338 - 339 - return [llength [$nodeListNode childNodes]] 340 -} 341 - 342 -#---------------------------------------------------------------------------- 343 -# appendData on a 'CharacterData' object 344 -# 345 -#---------------------------------------------------------------------------- 346 -proc ::dom::domNode::appendData { node arg } { 347 - 348 - set type [$node nodeType] 349 - if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 350 - ($type != "COMMENT_NODE") 351 - } { 352 - return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 353 - } 354 - set oldValue [$node nodeValue] 355 - $node nodeValue [append oldValue $arg] 356 -} 357 - 358 -#---------------------------------------------------------------------------- 359 -# deleteData on a 'CharacterData' object 360 -# 361 -#---------------------------------------------------------------------------- 362 -proc ::dom::domNode::deleteData { node offset count } { 363 - 364 - set type [$node nodeType] 365 - if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 366 - ($type != "COMMENT_NODE") 367 - } { 368 - return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 369 - } 370 - incr offset -1 371 - set before [string range [$node nodeValue] 0 $offset] 372 - incr offset 373 - incr offset $count 374 - set after [string range [$node nodeValue] $offset end] 375 - $node nodeValue [append before $after] 376 -} 377 - 378 -#---------------------------------------------------------------------------- 379 -# insertData on a 'CharacterData' object 380 -# 381 -#---------------------------------------------------------------------------- 382 -proc ::dom::domNode::insertData { node offset arg } { 383 - 384 - set type [$node nodeType] 385 - if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 386 - ($type != "COMMENT_NODE") 387 - } { 388 - return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 389 - } 390 - incr offset -1 391 - set before [string range [$node nodeValue] 0 $offset] 392 - incr offset 393 - set after [string range [$node nodeValue] $offset end] 394 - $node nodeValue [append before $arg $after] 395 -} 396 - 397 -#---------------------------------------------------------------------------- 398 -# replaceData on a 'CharacterData' object 399 -# 400 -#---------------------------------------------------------------------------- 401 -proc ::dom::domNode::replaceData { node offset count arg } { 402 - 403 - set type [$node nodeType] 404 - if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 405 - ($type != "COMMENT_NODE") 406 - } { 407 - return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 408 - } 409 - incr offset -1 410 - set before [string range [$node nodeValue] 0 $offset] 411 - incr offset 412 - incr offset $count 413 - set after [string range [$node nodeValue] $offset end] 414 - $node nodeValue [append before $arg $after] 415 -} 416 - 417 -#---------------------------------------------------------------------------- 418 -# substringData on a 'CharacterData' object 419 -# 420 -# @return part of the node value (text) 421 -# 422 -#---------------------------------------------------------------------------- 423 -proc ::dom::domNode::substringData { node offset count } { 424 - 425 - set type [$node nodeType] 426 - if {($type != "TEXT_NODE") && ($type != "CDATA_SECTION_NODE") && 427 - ($type != "COMMENT_NODE") 428 - } { 429 - return -code error "NOT_SUPPORTED_ERR: node is not a cdata node" 430 - } 431 - set endOffset [expr $offset + $count - 1] 432 - return [string range [$node nodeValue] $offset $endOffset] 433 -} 434 - 435 -#---------------------------------------------------------------------------- 436 -# coerce2number 437 -# 438 -#---------------------------------------------------------------------------- 439 -proc ::dom::xpathFuncHelper::coerce2number { type value } { 440 - switch $type { 441 - empty { return 0 } 442 - number - 443 - string { return $value } 444 - attrvalues { return [lindex $value 0] } 445 - nodes { return [[lindex $value 0] selectNodes number()] } 446 - attrnodes { return [lindex $value 1] } 447 - } 448 -} 449 - 450 -#---------------------------------------------------------------------------- 451 -# coerce2string 452 -# 453 -#---------------------------------------------------------------------------- 454 -proc ::dom::xpathFuncHelper::coerce2string { type value } { 455 - switch $type { 456 - empty { return "" } 457 - number - 458 - string { return $value } 459 - attrvalues { return [lindex $value 0] } 460 - nodes { return [[lindex $value 0] selectNodes string()] } 461 - attrnodes { return [lindex $value 1] } 462 - } 463 -} 464 - 465 -#---------------------------------------------------------------------------- 466 -# function-available 467 -# 468 -#---------------------------------------------------------------------------- 469 -proc ::dom::xpathFunc::function-available { ctxNode pos 470 - nodeListType nodeList args} { 471 - 472 - if {[llength $args] != 2} { 473 - error "function-available(): wrong # of args!" 474 - } 475 - foreach { arg1Typ arg1Value } $args break 476 - set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ] 477 - switch $str { 478 - boolean - 479 - ceiling - 480 - concat - 481 - contains - 482 - count - 483 - current - 484 - document - 485 - element-available - 486 - false - 487 - floor - 488 - format-number - 489 - generate-id - 490 - id - 491 - key - 492 - last - 493 - lang - 494 - local-name - 495 - name - 496 - namespace-uri - 497 - normalize-space - 498 - not - 499 - number - 500 - position - 501 - round - 502 - starts-with - 503 - string - 504 - string-length - 505 - substring - 506 - substring-after - 507 - substring-before - 508 - sum - 509 - translate - 510 - true - 511 - unparsed-entity-uri { 512 - return [list bool true] 513 - } 514 - default { 515 - set TclXpathFuncs [info procs ::dom::xpathFunc::*] 516 - if {[lsearch -exact $TclXpathFuncs $str] != -1} { 517 - return [list bool true] 518 - } else { 519 - return [list bool false] 520 - } 521 - } 522 - } 523 -} 524 - 525 -#---------------------------------------------------------------------------- 526 -# element-available 527 -# 528 -# This is not strictly correct. The XSLT namespace may be bound 529 -# to another prefix (and the prefix 'xsl' may be bound to another 530 -# namespace). Since the expression context isn't available at the 531 -# moment at tcl coded XPath functions, this couldn't be done better 532 -# than this "works in the 'normal' cases" version. 533 -#---------------------------------------------------------------------------- 534 -proc ::dom::xpathFunc::element-available { ctxNode pos 535 - nodeListType nodeList args} { 536 - 537 - if {[llength $args] != 2} { 538 - error "element-available(): wrong # of args!" 539 - } 540 - foreach { arg1Typ arg1Value } $args break 541 - set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ] 542 - # The XSLT recommendation says: "The element-available 543 - # function returns true if and only if the expanded-name 544 - # is the name of an instruction." The following xsl 545 - # elements are not in the category instruction. 546 - # xsl:attribute-set 547 - # xsl:decimal-format 548 - # xsl:include 549 - # xsl:key 550 - # xsl:namespace-alias 551 - # xsl:output 552 - # xsl:param 553 - # xsl:strip-space 554 - # xsl:preserve-space 555 - # xsl:template 556 - # xsl:import 557 - # xsl:otherwise 558 - # xsl:sort 559 - # xsl:stylesheet 560 - # xsl:transform 561 - # xsl:with-param 562 - # xsl:when 563 - switch $str { 564 - xsl:apply-templates - 565 - xsl:apply-imports - 566 - xsl:call-template - 567 - xsl:element - 568 - xsl:attribute - 569 - xsl:text - 570 - xsl:processing-instruction - 571 - xsl:comment - 572 - xsl:copy - 573 - xsl:value-of - 574 - xsl:number - 575 - xsl:for-each - 576 - xsl:if - 577 - xsl:choose - 578 - xsl:variable - 579 - xsl:copy-of - 580 - xsl:message - 581 - xsl:fallback { 582 - return [list bool true] 583 - } 584 - default { 585 - return [list bool false] 586 - } 587 - } 588 -} 589 - 590 -#---------------------------------------------------------------------------- 591 -# system-property 592 -# 593 -# This is not strictly correct. The XSLT namespace may be bound 594 -# to another prefix (and the prefix 'xsl' may be bound to another 595 -# namespace). Since the expression context isn't available at the 596 -# moment at tcl coded XPath functions, this couldn't be done better 597 -# than this "works in the 'normal' cases" version. 598 -#---------------------------------------------------------------------------- 599 -proc ::dom::xpathFunc::system-property { ctxNode pos 600 - nodeListType nodeList args } { 601 - 602 - if {[llength $args] != 2} { 603 - error "system-property(): wrong # of args!" 604 - } 605 - foreach { arg1Typ arg1Value } $args break 606 - set str [::dom::xpathFuncHelper::coerce2string $arg1Typ $arg1Value ] 607 - switch $str { 608 - xsl:version { 609 - return [list number 1.0] 610 - } 611 - xsl:vendor { 612 - return [list string "Jochen Loewer (loewerj@hotmail.com), Rolf Ade (rolf@pointsman.de) et. al."] 613 - } 614 - xsl:vendor-url { 615 - return [list string "http://www.tdom.org"] 616 - } 617 - default { 618 - return [list string ""] 619 - } 620 - } 621 -} 622 - 623 -#---------------------------------------------------------------------------- 624 -# IANAEncoding2TclEncoding 625 -# 626 -#---------------------------------------------------------------------------- 627 - 628 -# As of version 8.3.4 tcl supports 629 -# cp860 cp861 cp862 cp863 tis-620 cp864 cp865 cp866 gb12345 cp949 630 -# cp950 cp869 dingbats ksc5601 macCentEuro cp874 macUkraine jis0201 631 -# gb2312 euc-cn euc-jp iso8859-10 macThai jis0208 iso2022-jp 632 -# macIceland iso2022 iso8859-13 iso8859-14 jis0212 iso8859-15 cp737 633 -# iso8859-16 big5 euc-kr macRomania macTurkish gb1988 iso2022-kr 634 -# macGreek ascii cp437 macRoman iso8859-1 iso8859-2 iso8859-3 ebcdic 635 -# macCroatian koi8-r iso8859-4 iso8859-5 cp1250 macCyrillic iso8859-6 636 -# cp1251 koi8-u macDingbats iso8859-7 cp1252 iso8859-8 cp1253 637 -# iso8859-9 cp1254 cp1255 cp850 cp1256 cp932 identity cp1257 cp852 638 -# macJapan cp1258 shiftjis utf-8 cp855 cp936 symbol cp775 unicode 639 -# cp857 640 -# 641 -# Just add more mappings (and mail them to the tDOM mailing list, please). 642 - 643 -proc tDOM::IANAEncoding2TclEncoding {IANAName} { 644 - 645 - # First the most widespread encodings with there 646 - # preferred MIME name, to speed lookup in this 647 - # usual cases. Later the official names and the 648 - # aliases. 649 - # 650 - # For "official names for character sets that may be 651 - # used in the Internet" see 652 - # http://www.iana.org/assignments/character-sets 653 - # (that's the source for the encoding names below) 654 - # 655 - # Matching is case-insensitive 656 - 657 - switch [string tolower $IANAName] { 658 - "us-ascii" {return ascii} 659 - "utf-8" {return utf-8} 660 - "utf-16" {return unicode; # not sure about this} 661 - "iso-8859-1" {return iso8859-1} 662 - "iso-8859-2" {return iso8859-2} 663 - "iso-8859-3" {return iso8859-3} 664 - "iso-8859-4" {return iso8859-4} 665 - "iso-8859-5" {return iso8859-5} 666 - "iso-8859-6" {return iso8859-6} 667 - "iso-8859-7" {return iso8859-7} 668 - "iso-8859-8" {return iso8859-8} 669 - "iso-8859-9" {return iso8859-9} 670 - "iso-8859-10" {return iso8859-10} 671 - "iso-8859-13" {return iso8859-13} 672 - "iso-8859-14" {return iso8859-14} 673 - "iso-8859-15" {return iso8859-15} 674 - "iso-8859-16" {return iso8859-16} 675 - "iso-2022-kr" {return iso2022-kr} 676 - "euc-kr" {return euc-kr} 677 - "iso-2022-jp" {return iso2022-jp} 678 - "koi8-r" {return koi8-r} 679 - "shift_jis" {return shiftjis} 680 - "euc-jp" {return euc-jp} 681 - "gb2312" {return gb2312} 682 - "big5" {return big5} 683 - "cp866" {return cp866} 684 - "cp1250" {return cp1250} 685 - "cp1253" {return cp1253} 686 - "cp1254" {return cp1254} 687 - "cp1255" {return cp1255} 688 - "cp1256" {return cp1256} 689 - "cp1257" {return cp1257} 690 - 691 - "windows-1251" - 692 - "cp1251" {return cp1251} 693 - 694 - "windows-1252" - 695 - "cp1252" {return cp1252} 696 - 697 - "iso_8859-1:1987" - 698 - "iso-ir-100" - 699 - "iso_8859-1" - 700 - "latin1" - 701 - "l1" - 702 - "ibm819" - 703 - "cp819" - 704 - "csisolatin1" {return iso8859-1} 705 - 706 - "iso_8859-2:1987" - 707 - "iso-ir-101" - 708 - "iso_8859-2" - 709 - "iso-8859-2" - 710 - "latin2" - 711 - "l2" - 712 - "csisolatin2" {return iso8859-2} 713 - 714 - "iso_8859-5:1988" - 715 - "iso-ir-144" - 716 - "iso_8859-5" - 717 - "iso-8859-5" - 718 - "cyrillic" - 719 - "csisolatincyrillic" {return iso8859-5} 720 - 721 - "ms_kanji" - 722 - "csshiftjis" {return shiftjis} 723 - 724 - "csiso2022kr" {return iso2022-kr} 725 - 726 - "ibm866" - 727 - "csibm866" {return cp866} 728 - 729 - default { 730 - # There are much more encoding names out there 731 - # It's only laziness, that let me stop here. 732 - error "Unrecognized encoding name '$IANAName'" 733 - } 734 - } 735 -} 736 - 737 -#---------------------------------------------------------------------------- 738 -# xmlOpenFile 739 -# 740 -#---------------------------------------------------------------------------- 741 -proc tDOM::xmlOpenFile {filename {encodingString {}}} { 742 - 743 - set fd [open $filename] 744 - 745 - if {$encodingString != {}} { 746 - upvar $encodingString encString 747 - } 748 - 749 - # The autodetection of the encoding follows 750 - # XML Recomendation, Appendix F 751 - 752 - fconfigure $fd -encoding binary 753 - if {![binary scan [read $fd 4] "H8" firstBytes]} { 754 - # very short (< 4 Bytes) file 755 - seek $fd 0 start 756 - set encString UTF-8 757 - return $fd 758 - } 759 - 760 - # First check for BOM 761 - switch [string range $firstBytes 0 3] { 762 - "feff" - 763 - "fffe" { 764 - # feff: UTF-16, big-endian BOM 765 - # ffef: UTF-16, little-endian BOM 766 - seek $fd 0 start 767 - set encString UTF-16 768 - fconfigure $fd -encoding identity 769 - return $fd 770 - } 771 - } 772 - 773 - # If the entity has a XML Declaration, the first four characters 774 - # must be "<?xm". 775 - switch $firstBytes { 776 - "3c3f786d" { 777 - # UTF-8, ISO 646, ASCII, some part of ISO 8859, Shift-JIS, 778 - # EUC, or any other 7-bit, 8-bit, or mixed-width encoding which 779 - # ensures that the characters of ASCII have their normal positions, 780 - # width and values; the actual encoding declaration must be read to 781 - # detect which of these applies, but since all of these encodings 782 - # use the same bit patterns for the ASCII characters, the encoding 783 - # declaration itself be read reliably. 784 - 785 - # First 300 bytes should be enough for a XML Declaration 786 - # This is of course not 100 percent bullet-proof. 787 - set head [read $fd 296] 788 - 789 - # Try to find the end of the XML Declaration 790 - set closeIndex [string first ">" $head] 791 - if {$closeIndex == -1} { 792 - error "Weird XML data or not XML data at all" 793 - } 794 - 795 - seek $fd 0 start 796 - set xmlDeclaration [read $fd [expr {$closeIndex + 5}]] 797 - # extract the encoding information 798 - set pattern {^[^>]+encoding=[\x20\x9\xd\xa]*["']([^ "']+)['"]} 799 - # emacs: " 800 - if {![regexp $pattern $head - encStr]} { 801 - # Probably something like <?xml version="1.0"?>. 802 - # Without encoding declaration this must be UTF-8 803 - set encoding utf-8 804 - set encString UTF-8 805 - } else { 806 - set encoding [IANAEncoding2TclEncoding $encStr] 807 - set encString $encStr 808 - } 809 - } 810 - "0000003c" - 811 - "0000003c" - 812 - "3c000000" - 813 - "00003c00" { 814 - # UCS-4 815 - error "UCS-4 not supported" 816 - } 817 - "003c003f" - 818 - "3c003f00" { 819 - # UTF-16, big-endian, no BOM 820 - # UTF-16, little-endian, no BOM 821 - seek $fd 0 start 822 - set encoding identity 823 - set encString UTF-16 824 - } 825 - "4c6fa794" { 826 - # EBCDIC in some flavor 827 - error "EBCDIC not supported" 828 - } 829 - default { 830 - # UTF-8 without an encoding declaration 831 - seek $fd 0 start 832 - set encoding identity 833 - set encString "UTF-8" 834 - } 835 - } 836 - fconfigure $fd -encoding $encoding 837 - return $fd 838 -} 839 - 840 -#---------------------------------------------------------------------------- 841 -# xmlReadFile 842 -# 843 -#---------------------------------------------------------------------------- 844 -proc tDOM::xmlReadFile {filename {encodingString {}}} { 845 - 846 - if {$encodingString != {}} { 847 - upvar $encodingString encString 848 - } 849 - 850 - set fd [xmlOpenFile $filename encString] 851 - set data [read $fd [file size $filename]] 852 - close $fd 853 - return $data 854 -} 855 - 856 -#---------------------------------------------------------------------------- 857 -# extRefHandler 858 -# 859 -# A very simple external entity resolver, included for convenience. 860 -# Depends on the tcllib package uri and resolves only file URLs. 861 -# 862 -#---------------------------------------------------------------------------- 863 - 864 -if {![catch {package require uri}]} { 865 - proc tDOM::extRefHandler {base systemId publicId} { 866 - variable extRefHandlerDebug 867 - variable useForeignDTD 868 - 869 - if {$extRefHandlerDebug} { 870 - puts stderr "tDOM::extRefHandler called with:" 871 - puts stderr "\tbase: '$base'" 872 - puts stderr "\tsystemId: '$systemId'" 873 - puts stderr "\tpublicId: '$publicId'" 874 - } 875 - if {$systemId == ""} { 876 - if {$useForeignDTD != ""} { 877 - set systemId $useForeignDTD 878 - } else { 879 - error "::tDOM::useForeignDTD does\ 880 - not point to the foreign DTD" 881 - } 882 - } 883 - set absolutURI [uri::resolve $base $systemId] 884 - array set uriData [uri::split $absolutURI] 885 - switch $uriData(scheme) { 886 - file { 887 - return [list string $absolutURI [xmlReadFile $uriData(path)]] 888 - } 889 - default { 890 - error "can only handle file URI's" 891 - } 892 - } 893 - } 894 -} 895 - 896 -#---------------------------------------------------------------------------- 897 -# baseURL 898 -# 899 -# A simple convenience proc which returns an absolute URL for a given 900 -# filename. 901 -# 902 -#---------------------------------------------------------------------------- 903 - 904 -proc tDOM::baseURL {path} { 905 - switch [file pathtype $path] { 906 - "relative" { 907 - return "file://[pwd]/$path" 908 - } 909 - default { 910 - return "file://$path" 911 - } 912 - } 913 -} 914 - 915 -# EOF
Deleted winlibs/tdom/tdom083.dll.
cannot compute difference between binary files
Deleted winlibs/twapi/LICENSE.
1 -Copyright (c) 2003-2012, Ashok P. Nadkarni 2 -All rights reserved. 3 - 4 -Redistribution and use in source and binary forms, with or without 5 -modification, are permitted provided that the following conditions are 6 -met: 7 - 8 -- Redistributions of source code must retain the above copyright notice, 9 -this list of conditions and the following disclaimer. 10 - 11 -- Redistributions in binary form must reproduce the above copyright 12 -notice, this list of conditions and the following disclaimer in the 13 -documentation and/or other materials provided with the distribution. 14 - 15 -- The name of the copyright holder and any other contributors may not 16 -be used to endorse or promote products derived from this software 17 -without specific prior written permission. 18 - 19 -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Deleted winlibs/twapi/README.TXT.
1 -# Tcl Windows API (TWAPI) 4.1 2 - 3 -This is the release version of TWAPI 4.1. 4 - 5 - * Project home page is at http://twapi.sourceforge.net 6 - * V4.1 documentation is at http://twapi.sourceforge.net/v4.1 7 - 8 -## Supported platforms 9 - 10 -TWAPI 4.1 requires 11 - 12 - * Windows XP (32-bit only) or later (32- or 64- bit) 13 - * Tcl 8.5 or 8.6 (32- or 64-bit) 14 - 15 -## Changes since 4.0 16 - 17 -Major changes in this release are support for writing COM servers 18 -and other COM enhancements, STARTTLS support for TLS sockets, 19 -and additional functionality in the security, services, 20 -device management and console modules. 21 - 22 -For a complete list, including INCOMPATIBLE CHANGES, see 23 -http://twapi.sourceforge.net/v4.1/versionhistory.html 24 - 25 -## Distributions 26 - 27 -TWAPI is distributed in multiple formats. 28 -See http://twapi.sourceforge.net/v4.1/installation.html for the details 29 -and the pros and cons of each format. 30 - 31 -## TWAPI Summary 32 - 33 -The Tcl Windows API (TWAPI) extension provides 34 -access to over 600 functions in the Windows API 35 -from within the Tcl scripting language. 36 - 37 -Functions in the following areas are implemented: 38 - 39 - * System functions including OS and CPU information, 40 - shutdown and message formatting 41 - * User and group management 42 - * COM client and server support 43 - * Security and resource access control 44 - * Window management 45 - * User input: generate key/mouse input and hotkeys 46 - * Basic sound playback functions 47 - * Windows services 48 - * Windows event log access 49 - * Windows event tracing 50 - * Process and thread management 51 - * Directory change monitoring 52 - * Lan Manager and file and print shares 53 - * Drive information, file system types etc. 54 - * Network configuration and statistics 55 - * Network connection monitoring and control 56 - * Named pipes 57 - * Clipboard access 58 - * Taskbar icons and notifications 59 - * Console mode functions 60 - * Window stations and desktops 61 - * Internationalization 62 - * Task scheduling 63 - * Shell functions 64 - * Windows Installer 65 - * Synchronization 66 - * Power management 67 - * Device I/O and management 68 - * Crypto API and certificates 69 - * SSL/TLS 70 - * Windows Performance Counters
Deleted winlibs/twapi/accounts.tcl.
1 -# 2 -# Copyright (c) 2009-2015, Ashok P. Nadkarni 3 -# All rights reserved. 4 -# 5 -# See the file LICENSE for license 6 - 7 -package require twapi_security 8 - 9 -namespace eval twapi { 10 - record USER_INFO_0 {-name} 11 - record USER_INFO_1 [concat [USER_INFO_0] { 12 - -password -password_age -priv -home_dir -comment -flags -script_path 13 - }] 14 - record USER_INFO_2 [concat [USER_INFO_1] { 15 - -auth_flags -full_name -usr_comment -parms 16 - -workstations -last_logon -last_logoff -acct_expires -max_storage 17 - -units_per_week -logon_hours -bad_pw_count -num_logons 18 - -logon_server -country_code -code_page 19 - }] 20 - record USER_INFO_3 [concat [USER_INFO_2] { 21 - -user_id -primary_group_id -profile -home_dir_drive -password_expired 22 - }] 23 - record USER_INFO_4 [concat [USER_INFO_2] { 24 - -sid -primary_group_id -profile -home_dir_drive -password_expired 25 - }] 26 - 27 - record GROUP_INFO_0 {-name} 28 - record GROUP_INFO_1 {-name -comment} 29 - record GROUP_INFO_2 {-name -comment -group_id -attributes} 30 - record GROUP_INFO_3 {-name -comment -sid -attributes} 31 - 32 - record NetEnumResult {moredata hresume totalentries entries} 33 - 34 -} 35 - 36 -# Add a new user account 37 -proc twapi::new_user {username args} { 38 - array set opts [parseargs args [list \ 39 - system.arg \ 40 - password.arg \ 41 - comment.arg \ 42 - [list priv.arg "user" [array names twapi::priv_level_map]] \ 43 - home_dir.arg \ 44 - script_path.arg \ 45 - ] \ 46 - -nulldefault] 47 - 48 - if {$opts(priv) ne "user"} { 49 - error "Option -priv is deprecated and values other than 'user' are not allowed" 50 - } 51 - 52 - # 1 -> priv level 'user'. NetUserAdd mandates this as only allowed value 53 - NetUserAdd $opts(system) $username $opts(password) 1 \ 54 - $opts(home_dir) $opts(comment) 0 $opts(script_path) 55 - 56 - 57 - # Backward compatibility - add to 'Users' local group 58 - # but only if -system is local 59 - if {$opts(system) eq "" || 60 - ([info exists ::env(COMPUTERNAME)] && 61 - [string equal -nocase $opts(system) $::env(COMPUTERNAME)])} { 62 - trap { 63 - _set_user_priv_level $username $opts(priv) -system $opts(system) 64 - } onerror {} { 65 - # Remove the previously created user account 66 - catch {delete_user $username -system $opts(system)} 67 - rethrow 68 - } 69 - } 70 -} 71 - 72 - 73 -# Delete a user account 74 -proc twapi::delete_user {username args} { 75 - array set opts [parseargs args {system.arg} -nulldefault] 76 - 77 - # Remove the user from the LSA rights database. 78 - _delete_rights $username $opts(system) 79 - 80 - NetUserDel $opts(system) $username 81 -} 82 - 83 - 84 -# Define various functions to set various user account fields 85 -foreach twapi::_field_ { 86 - {name 0} 87 - {password 1003} 88 - {home_dir 1006} 89 - {comment 1007} 90 - {script_path 1009} 91 - {full_name 1011} 92 - {country_code 1024} 93 - {profile 1052} 94 - {home_dir_drive 1053} 95 -} { 96 - proc twapi::set_user_[lindex $::twapi::_field_ 0] {username fieldval args} " 97 - array set opts \[parseargs args { 98 - system.arg 99 - } -nulldefault \] 100 - Twapi_NetUserSetInfo [lindex $::twapi::_field_ 1] \$opts(system) \$username \$fieldval" 101 -} 102 -unset twapi::_field_ 103 - 104 -# Set account expiry time 105 -proc twapi::set_user_expiration {username time args} { 106 - array set opts [parseargs args {system.arg} -nulldefault] 107 - 108 - if {![string is integer -strict $time]} { 109 - if {[string equal $time "never"]} { 110 - set time -1 111 - } else { 112 - set time [clock scan $time] 113 - } 114 - } 115 - Twapi_NetUserSetInfo 1017 $opts(system) $username $time 116 -} 117 - 118 -# Unlock a user account 119 -proc twapi::unlock_user {username args} { 120 - # UF_LOCKOUT -> 0x10 121 - _change_user_info_flags $username 0x10 0 {*}$args 122 -} 123 - 124 -# Enable a user account 125 -proc twapi::enable_user {username args} { 126 - # UF_ACCOUNTDISABLE -> 0x2 127 - _change_user_info_flags $username 0x2 0 {*}$args 128 -} 129 - 130 -# Disable a user account 131 -proc twapi::disable_user {username args} { 132 - # UF_ACCOUNTDISABLE -> 0x2 133 - _change_user_info_flags $username 0x2 0x2 {*}$args 134 -} 135 - 136 - 137 -# Return the specified fields for a user account 138 -proc twapi::get_user_account_info {account args} { 139 - # Define each option, the corresponding field, and the 140 - # information level at which it is returned 141 - array set fields { 142 - comment 1 143 - password_expired 4 144 - full_name 2 145 - parms 2 146 - units_per_week 2 147 - primary_group_id 4 148 - flags 1 149 - logon_server 2 150 - country_code 2 151 - home_dir 1 152 - password_age 1 153 - home_dir_drive 4 154 - num_logons 2 155 - acct_expires 2 156 - last_logon 2 157 - usr_comment 2 158 - bad_pw_count 2 159 - code_page 2 160 - logon_hours 2 161 - workstations 2 162 - last_logoff 2 163 - name 0 164 - script_path 1 165 - profile 4 166 - max_storage 2 167 - } 168 - # Left out - auth_flags 2 169 - # Left out (always returned as NULL) - password {usri3_password 1} 170 - # Note sid is available at level 4 as well but don't want to set 171 - # level 4 just for that since we can get it by other means. Hence 172 - # not listed above 173 - 174 - array set opts [parseargs args \ 175 - [concat [array names fields] sid \ 176 - internet_identity \ 177 - status type password_attrs \ 178 - [list local_groups global_groups system.arg all]] \ 179 - -nulldefault] 180 - 181 - if {$opts(all)} { 182 - set level 4 183 - set opts(local_groups) 1 184 - set opts(global_groups) 1 185 - } else { 186 - # Based on specified fields, figure out what level info to ask for 187 - set level -1 188 - foreach {opt optval} [array get opts] { 189 - if {[info exists fields($opt)] && 190 - $optval && 191 - $fields($opt) > $level 192 - } { 193 - set level $fields($opt) 194 - } 195 - } 196 - if {$opts(status) || $opts(type) || $opts(password_attrs)} { 197 - # These fields are based on the flags field 198 - if {$level < 1} { 199 - set level 1 200 - } 201 - } 202 - } 203 - 204 - array set result [list ] 205 - 206 - if {$level > -1} { 207 - set rawdata [NetUserGetInfo $opts(system) $account $level] 208 - array set data [USER_INFO_$level $rawdata] 209 - 210 - # Extract the requested data 211 - foreach opt [array names fields] { 212 - if {$opts(all) || $opts($opt)} { 213 - set result(-$opt) $data(-$opt) 214 - } 215 - } 216 - if {$level == 4 && ($opts(all) || $opts(sid))} { 217 - set result(-sid) $data(-sid) 218 - } 219 - 220 - # Map internal values to more friendly formats 221 - if {$opts(all) || $opts(status) || $opts(type) || $opts(password_attrs)} { 222 - array set result [_map_userinfo_flags $data(-flags)] 223 - if {! $opts(all)} { 224 - if {! $opts(status)} {unset result(-status)} 225 - if {! $opts(type)} {unset result(-type)} 226 - if {! $opts(password_attrs)} {unset result(-password_attrs)} 227 - } 228 - } 229 - 230 - if {[info exists result(-logon_hours)]} { 231 - binary scan $result(-logon_hours) b* result(-logon_hours) 232 - } 233 - 234 - foreach time_field {-acct_expires -last_logon -last_logoff} { 235 - if {[info exists result($time_field)]} { 236 - if {$result($time_field) == -1 || $result($time_field) == 4294967295} { 237 - set result($time_field) "never" 238 - } elseif {$result($time_field) == 0} { 239 - set result($time_field) "unknown" 240 - } 241 - } 242 - } 243 - } 244 - 245 - if {$opts(all) || $opts(internet_identity)} { 246 - set result(-internet_identity) {} 247 - if {[min_os_version 6 2]} { 248 - set inet_ident [NetUserGetInfo $opts(system) $account 24] 249 - if {[llength $inet_ident]} { 250 - set result(-internet_identity) [twine { 251 - internet_provider_name internet_principal_name sid 252 - } [lrange $inet_ident 1 end]] 253 - } 254 - } 255 - } 256 - 257 - # The Net* calls always return structures as lists even when the struct 258 - # contains only one field so we need to lpick to extract the field 259 - 260 - if {$opts(local_groups)} { 261 - set result(-local_groups) [lpick [NetEnumResult entries [NetUserGetLocalGroups $opts(system) $account 0 0]] 0] 262 - } 263 - 264 - if {$opts(global_groups)} { 265 - set result(-global_groups) [lpick [NetEnumResult entries [NetUserGetGroups $opts(system) $account 0]] 0] 266 - } 267 - 268 - if {$opts(sid) && ! [info exists result(-sid)]} { 269 - set result(-sid) [lookup_account_name $account -system $opts(system)] 270 - } 271 - 272 - return [array get result] 273 -} 274 - 275 -proc twapi::get_user_global_groups {account args} { 276 - parseargs args { 277 - system.arg 278 - denyonly 279 - all 280 - } -nulldefault -maxleftover 0 -setvars 281 - 282 - set groups {} 283 - foreach elem [NetEnumResult entries [NetUserGetGroups $system [map_account_to_name $account -system $system] 1]] { 284 - # 0x10 -> SE_GROUP_USE_FOR_DENY_ONLY 285 - set marked_denyonly [expr {[lindex $elem 1] & 0x10}] 286 - if {$all || ($denyonly && $marked_denyonly) || !($denyonly || $marked_denyonly)} { 287 - lappend groups [lindex $elem 0] 288 - } 289 - } 290 - return $groups 291 -} 292 - 293 -proc twapi::get_user_local_groups {account args} { 294 - parseargs args { 295 - system.arg 296 - {recurse.bool 0} 297 - } -nulldefault -maxleftover 0 -setvars 298 - 299 - # The Net* calls always return structures as lists even when the struct 300 - # contains only one field so we need to lpick to extract the field 301 - return [lpick [NetEnumResult entries [NetUserGetLocalGroups $system [map_account_to_name $account -system $system] 0 $recurse]] 0] 302 -} 303 - 304 -proc twapi::get_user_local_groups_recursive {account args} { 305 - return [get_user_local_groups $account {*}$args -recurse 1] 306 -} 307 - 308 - 309 -# Set the specified fields for a user account 310 -proc twapi::set_user_account_info {account args} { 311 - 312 - # Define each option, the corresponding field, and the 313 - # information level at which it is returned 314 - array set opts [parseargs args { 315 - {system.arg ""} 316 - comment.arg 317 - full_name.arg 318 - country_code.arg 319 - home_dir.arg 320 - home_dir.arg 321 - acct_expires.arg 322 - name.arg 323 - script_path.arg 324 - profile.arg 325 - }] 326 - 327 - # TBD - rewrite this to be atomic 328 - 329 - if {[info exists opts(comment)]} { 330 - set_user_comment $account $opts(comment) -system $opts(system) 331 - } 332 - 333 - if {[info exists opts(full_name)]} { 334 - set_user_full_name $account $opts(full_name) -system $opts(system) 335 - } 336 - 337 - if {[info exists opts(country_code)]} { 338 - set_user_country_code $account $opts(country_code) -system $opts(system) 339 - } 340 - 341 - if {[info exists opts(home_dir)]} { 342 - set_user_home_dir $account $opts(home_dir) -system $opts(system) 343 - } 344 - 345 - if {[info exists opts(home_dir_drive)]} { 346 - set_user_home_dir_drive $account $opts(home_dir_drive) -system $opts(system) 347 - } 348 - 349 - if {[info exists opts(acct_expires)]} { 350 - set_user_expiration $account $opts(acct_expires) -system $opts(system) 351 - } 352 - 353 - if {[info exists opts(name)]} { 354 - set_user_name $account $opts(name) -system $opts(system) 355 - } 356 - 357 - if {[info exists opts(script_path)]} { 358 - set_user_script_path $account $opts(script_path) -system $opts(system) 359 - } 360 - 361 - if {[info exists opts(profile)]} { 362 - set_user_profile $account $opts(profile) -system $opts(system) 363 - } 364 -} 365 - 366 - 367 -proc twapi::get_global_group_info {grpname args} { 368 - array set opts [parseargs args { 369 - {system.arg ""} 370 - comment 371 - name 372 - members 373 - sid 374 - attributes 375 - all 376 - } -maxleftover 0] 377 - 378 - set result {} 379 - if {[expr {$opts(comment) || $opts(name) || $opts(sid) || $opts(attributes) || $opts(all)}]} { 380 - # 3 -> GROUP_INFO level 3 381 - lassign [NetGroupGetInfo $opts(system) $grpname 3] name comment sid attributes 382 - if {$opts(all) || $opts(sid)} { 383 - lappend result -sid $sid 384 - } 385 - if {$opts(all) || $opts(name)} { 386 - lappend result -name $name 387 - } 388 - if {$opts(all) || $opts(comment)} { 389 - lappend result -comment $comment 390 - } 391 - if {$opts(all) || $opts(attributes)} { 392 - lappend result -attributes [map_token_group_attr $attributes] 393 - } 394 - } 395 - 396 - if {$opts(all) || $opts(members)} { 397 - lappend result -members [get_global_group_members $grpname -system $opts(system)] 398 - } 399 - 400 - return $result 401 -} 402 - 403 -# Get info about a local or global group 404 -proc twapi::get_local_group_info {name args} { 405 - array set opts [parseargs args { 406 - {system.arg ""} 407 - comment 408 - name 409 - members 410 - sid 411 - all 412 - } -maxleftover 0] 413 - 414 - set result [list ] 415 - if {$opts(all) || $opts(sid)} { 416 - lappend result -sid [lookup_account_name $name -system $opts(system)] 417 - } 418 - if {$opts(all) || $opts(comment) || $opts(name)} { 419 - lassign [NetLocalGroupGetInfo $opts(system) $name 1] name comment 420 - if {$opts(all) || $opts(name)} { 421 - lappend result -name $name 422 - } 423 - if {$opts(all) || $opts(comment)} { 424 - lappend result -comment $comment 425 - } 426 - } 427 - if {$opts(all) || $opts(members)} { 428 - lappend result -members [get_local_group_members $name -system $opts(system)] 429 - } 430 - return $result 431 -} 432 - 433 -# Get list of users on a system 434 -proc twapi::get_users {args} { 435 - parseargs args { 436 - level.int 437 - } -setvars -ignoreunknown 438 - 439 - # TBD -allow user to specify filter 440 - lappend args -filter 0 441 - if {[info exists level]} { 442 - lappend args -level $level -fields [USER_INFO_$level] 443 - } 444 - return [_net_enum_helper NetUserEnum $args] 445 -} 446 - 447 -proc twapi::get_global_groups {args} { 448 - parseargs args { 449 - level.int 450 - } -setvars -ignoreunknown 451 - 452 - # TBD - level 3 returns an ERROR_INVALID_LEVEL even though 453 - # MSDN says its valid for NetGroupEnum 454 - 455 - if {[info exists level]} { 456 - lappend args -level $level -fields [GROUP_INFO_$level] 457 - } 458 - return [_net_enum_helper NetGroupEnum $args] 459 -} 460 - 461 -proc twapi::get_local_groups {args} { 462 - parseargs args { 463 - level.int 464 - } -setvars -ignoreunknown 465 - 466 - if {[info exists level]} { 467 - lappend args -level $level -fields [dict get {0 {-name} 1 {-name -comment}} $level] 468 - } 469 - return [_net_enum_helper NetLocalGroupEnum $args] 470 -} 471 - 472 -# Create a new global group 473 -proc twapi::new_global_group {grpname args} { 474 - array set opts [parseargs args { 475 - system.arg 476 - comment.arg 477 - } -nulldefault] 478 - 479 - NetGroupAdd $opts(system) $grpname $opts(comment) 480 -} 481 - 482 -# Create a new local group 483 -proc twapi::new_local_group {grpname args} { 484 - array set opts [parseargs args { 485 - system.arg 486 - comment.arg 487 - } -nulldefault] 488 - 489 - NetLocalGroupAdd $opts(system) $grpname $opts(comment) 490 -} 491 - 492 - 493 -# Delete a global group 494 -proc twapi::delete_global_group {grpname args} { 495 - array set opts [parseargs args {system.arg} -nulldefault] 496 - 497 - # Remove the group from the LSA rights database. 498 - _delete_rights $grpname $opts(system) 499 - 500 - NetGroupDel $opts(system) $grpname 501 -} 502 - 503 -# Delete a local group 504 -proc twapi::delete_local_group {grpname args} { 505 - array set opts [parseargs args {system.arg} -nulldefault] 506 - 507 - # Remove the group from the LSA rights database. 508 - _delete_rights $grpname $opts(system) 509 - 510 - NetLocalGroupDel $opts(system) $grpname 511 -} 512 - 513 - 514 -# Enumerate members of a global group 515 -proc twapi::get_global_group_members {grpname args} { 516 - parseargs args { 517 - level.int 518 - } -setvars -ignoreunknown 519 - 520 - if {[info exists level]} { 521 - lappend args -level $level -fields [dict! {0 {-name} 1 {-name -attributes}} $level] 522 - } 523 - 524 - lappend args -preargs [list $grpname] -namelevel 1 525 - return [_net_enum_helper NetGroupGetUsers $args] 526 -} 527 - 528 -# Enumerate members of a local group 529 -proc twapi::get_local_group_members {grpname args} { 530 - parseargs args { 531 - level.int 532 - } -setvars -ignoreunknown 533 - 534 - if {[info exists level]} { 535 - lappend args -level $level -fields [dict! {0 {-sid} 1 {-sid -sidusage -name} 2 {-sid -sidusage -domainandname} 3 {-domainandname}} $level] 536 - } 537 - 538 - lappend args -preargs [list $grpname] -namelevel 1 -namefield 2 539 - return [_net_enum_helper NetLocalGroupGetMembers $args] 540 -} 541 - 542 -# Add a user to a global group 543 -proc twapi::add_user_to_global_group {grpname username args} { 544 - array set opts [parseargs args {system.arg} -nulldefault] 545 - 546 - # No error if already member of the group 547 - trap { 548 - NetGroupAddUser $opts(system) $grpname $username 549 - } onerror {TWAPI_WIN32 1320} { 550 - # Ignore 551 - } 552 -} 553 - 554 - 555 -# Remove a user from a global group 556 -proc twapi::remove_user_from_global_group {grpname username args} { 557 - array set opts [parseargs args {system.arg} -nulldefault] 558 - 559 - trap { 560 - NetGroupDelUser $opts(system) $grpname $username 561 - } onerror {TWAPI_WIN32 1321} { 562 - # Was not in group - ignore 563 - } 564 -} 565 - 566 - 567 -# Add a user to a local group 568 -proc twapi::add_member_to_local_group {grpname username args} { 569 - array set opts [parseargs args { 570 - system.arg 571 - {type.arg name} 572 - } -nulldefault] 573 - 574 - # No error if already member of the group 575 - trap { 576 - Twapi_NetLocalGroupMembers 0 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] [list $username] 577 - } onerror {TWAPI_WIN32 1378} { 578 - # Ignore 579 - } 580 -} 581 - 582 -proc twapi::add_members_to_local_group {grpname accts args} { 583 - array set opts [parseargs args { 584 - system.arg 585 - {type.arg name} 586 - } -nulldefault] 587 - 588 - Twapi_NetLocalGroupMembers 0 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] $accts 589 -} 590 - 591 - 592 -# Remove a user from a local group 593 -proc twapi::remove_member_from_local_group {grpname username args} { 594 - array set opts [parseargs args { 595 - system.arg 596 - {type.arg name} 597 - } -nulldefault] 598 - 599 - trap { 600 - Twapi_NetLocalGroupMembers 1 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] [list $username] 601 - } onerror {TWAPI_WIN32 1377} { 602 - # Was not in group - ignore 603 - } 604 -} 605 - 606 -proc twapi::remove_members_from_local_group {grpname accts args} { 607 - array set opts [parseargs args { 608 - system.arg 609 - {type.arg name} 610 - } -nulldefault] 611 - 612 - Twapi_NetLocalGroupMembers 1 $opts(system) $grpname [expr {$opts(type) eq "sid" ? 0 : 3}] $accts 613 -} 614 - 615 - 616 -# Get rights for an account 617 -proc twapi::get_account_rights {account args} { 618 - array set opts [parseargs args { 619 - {system.arg ""} 620 - } -maxleftover 0] 621 - 622 - set sid [map_account_to_sid $account -system $opts(system)] 623 - 624 - trap { 625 - set lsah [get_lsa_policy_handle -system $opts(system) -access policy_lookup_names] 626 - return [Twapi_LsaEnumerateAccountRights $lsah $sid] 627 - } onerror {TWAPI_WIN32 2} { 628 - # No specific rights for this account 629 - return [list ] 630 - } finally { 631 - if {[info exists lsah]} { 632 - close_lsa_policy_handle $lsah 633 - } 634 - } 635 -} 636 - 637 -# Get accounts having a specific right 638 -proc twapi::find_accounts_with_right {right args} { 639 - array set opts [parseargs args { 640 - {system.arg ""} 641 - name 642 - } -maxleftover 0] 643 - 644 - trap { 645 - set lsah [get_lsa_policy_handle \ 646 - -system $opts(system) \ 647 - -access { 648 - policy_lookup_names 649 - policy_view_local_information 650 - }] 651 - set accounts [list ] 652 - foreach sid [Twapi_LsaEnumerateAccountsWithUserRight $lsah $right] { 653 - if {$opts(name)} { 654 - if {[catch {lappend accounts [lookup_account_sid $sid -system $opts(system)]}]} { 655 - # No mapping for SID - can happen if account has been 656 - # deleted but LSA policy not updated accordingly 657 - lappend accounts $sid 658 - } 659 - } else { 660 - lappend accounts $sid 661 - } 662 - } 663 - return $accounts 664 - } onerror {TWAPI_WIN32 259} { 665 - # No accounts have this right 666 - return [list ] 667 - } finally { 668 - if {[info exists lsah]} { 669 - close_lsa_policy_handle $lsah 670 - } 671 - } 672 - 673 -} 674 - 675 -# Add/remove rights to an account 676 -proc twapi::_modify_account_rights {operation account rights args} { 677 - set switches { 678 - system.arg 679 - handle.arg 680 - } 681 - 682 - switch -exact -- $operation { 683 - add { 684 - # Nothing to do 685 - } 686 - remove { 687 - lappend switches all 688 - } 689 - default { 690 - error "Invalid operation '$operation' specified" 691 - } 692 - } 693 - 694 - array set opts [parseargs args $switches -maxleftover 0] 695 - 696 - if {[info exists opts(system)] && [info exists opts(handle)]} { 697 - error "Options -system and -handle may not be specified together" 698 - } 699 - 700 - if {[info exists opts(handle)]} { 701 - set lsah $opts(handle) 702 - set sid $account 703 - } else { 704 - if {![info exists opts(system)]} { 705 - set opts(system) "" 706 - } 707 - 708 - set sid [map_account_to_sid $account -system $opts(system)] 709 - # We need to open a policy handle ourselves. First try to open 710 - # with max privileges in case the account needs to be created 711 - # and then retry with lower privileges if that fails 712 - catch { 713 - set lsah [get_lsa_policy_handle \ 714 - -system $opts(system) \ 715 - -access { 716 - policy_lookup_names 717 - policy_create_account 718 - }] 719 - } 720 - if {![info exists lsah]} { 721 - set lsah [get_lsa_policy_handle \ 722 - -system $opts(system) \ 723 - -access policy_lookup_names] 724 - } 725 - } 726 - 727 - trap { 728 - if {$operation == "add"} { 729 - LsaAddAccountRights $lsah $sid $rights 730 - } else { 731 - LsaRemoveAccountRights $lsah $sid $opts(all) $rights 732 - } 733 - } finally { 734 - # Close the handle if we opened it 735 - if {! [info exists opts(handle)]} { 736 - close_lsa_policy_handle $lsah 737 - } 738 - } 739 -} 740 - 741 -interp alias {} twapi::add_account_rights {} twapi::_modify_account_rights add 742 -interp alias {} twapi::remove_account_rights {} twapi::_modify_account_rights remove 743 - 744 -# Return list of logon sesionss 745 -proc twapi::find_logon_sessions {args} { 746 - array set opts [parseargs args { 747 - user.arg 748 - type.arg 749 - tssession.arg 750 - } -maxleftover 0] 751 - 752 - set luids [LsaEnumerateLogonSessions] 753 - if {! ([info exists opts(user)] || [info exists opts(type)] || 754 - [info exists opts(tssession)])} { 755 - return $luids 756 - } 757 - 758 - 759 - # Need to get the data for each session to see if it matches 760 - set result [list ] 761 - if {[info exists opts(user)]} { 762 - set sid [map_account_to_sid $opts(user)] 763 - } 764 - if {[info exists opts(type)]} { 765 - set logontypes [list ] 766 - foreach logontype $opts(type) { 767 - lappend logontypes [_logon_session_type_code $logontype] 768 - } 769 - } 770 - 771 - foreach luid $luids { 772 - trap { 773 - unset -nocomplain session 774 - array set session [LsaGetLogonSessionData $luid] 775 - 776 - # For the local system account, no data is returned on some 777 - # platforms 778 - if {[array size session] == 0} { 779 - set session(Sid) S-1-5-18; # SYSTEM 780 - set session(Session) 0 781 - set session(LogonType) 0 782 - } 783 - if {[info exists opts(user)] && $session(Sid) ne $sid} { 784 - continue; # User id does not match 785 - } 786 - 787 - if {[info exists opts(type)] && [lsearch -exact $logontypes $session(LogonType)] < 0} { 788 - continue; # Type does not match 789 - } 790 - 791 - if {[info exists opts(tssession)] && $session(Session) != $opts(tssession)} { 792 - continue; # Term server session does not match 793 - } 794 - 795 - lappend result $luid 796 - 797 - } onerror {TWAPI_WIN32 1312} { 798 - # Session no longer exists. Just skip 799 - continue 800 - } 801 - } 802 - 803 - return $result 804 -} 805 - 806 - 807 -# Return data for a logon session 808 -proc twapi::get_logon_session_info {luid args} { 809 - array set opts [parseargs args { 810 - all 811 - authpackage 812 - dnsdomain 813 - logondomain 814 - logonid 815 - logonserver 816 - logontime 817 - type 818 - usersid 819 - user 820 - tssession 821 - userprincipal 822 - } -maxleftover 0] 823 - 824 - array set session [LsaGetLogonSessionData $luid] 825 - 826 - # Some fields may be missing on Win2K 827 - foreach fld {LogonServer DnsDomainName Upn} { 828 - if {![info exists session($fld)]} { 829 - set session($fld) "" 830 - } 831 - } 832 - 833 - array set result [list ] 834 - foreach {opt index} { 835 - authpackage AuthenticationPackage 836 - dnsdomain DnsDomainName 837 - logondomain LogonDomain 838 - logonid LogonId 839 - logonserver LogonServer 840 - logontime LogonTime 841 - type LogonType 842 - usersid Sid 843 - user UserName 844 - tssession Session 845 - userprincipal Upn 846 - } { 847 - if {$opts(all) || $opts($opt)} { 848 - set result(-$opt) $session($index) 849 - } 850 - } 851 - 852 - if {[info exists result(-type)]} { 853 - set result(-type) [_logon_session_type_symbol $result(-type)] 854 - } 855 - 856 - return [array get result] 857 -} 858 - 859 - 860 - 861 - 862 -# Set/reset the given bits in the usri3_flags field for a user account 863 -# mask indicates the mask of bits to set. values indicates the values 864 -# of those bits 865 -proc twapi::_change_user_info_flags {username mask values args} { 866 - array set opts [parseargs args { 867 - system.arg 868 - } -nulldefault -maxleftover 0] 869 - 870 - # Get current flags 871 - set flags [USER_INFO_1 -flags [NetUserGetInfo $opts(system) $username 1]] 872 - 873 - # Turn off mask bits and write flags back 874 - set flags [expr {$flags & (~ $mask)}] 875 - # Set the specified bits 876 - set flags [expr {$flags | ($values & $mask)}] 877 - 878 - # Write new flags back 879 - Twapi_NetUserSetInfo 1008 $opts(system) $username $flags 880 -} 881 - 882 -# Returns the logon session type value for a symbol 883 -twapi::proc* twapi::_logon_session_type_code {type} { 884 - variable _logon_session_type_map 885 - # Variable that maps logon session type codes to integer values 886 - # Position of each symbol gives its corresponding type value 887 - # See ntsecapi.h for definitions 888 - set _logon_session_type_map { 889 - 0 890 - 1 891 - interactive 892 - network 893 - batch 894 - service 895 - proxy 896 - unlockworkstation 897 - networkclear 898 - newcredentials 899 - remoteinteractive 900 - cachedinteractive 901 - cachedremoteinteractive 902 - cachedunlockworkstation 903 - } 904 -} { 905 - variable _logon_session_type_map 906 - 907 - # Type may be an integer or a token 908 - set code [lsearch -exact $_logon_session_type_map $type] 909 - if {$code >= 0} { 910 - return $code 911 - } 912 - 913 - if {![string is integer -strict $type]} { 914 - badargs! "Invalid logon session type '$type' specified" 3 915 - } 916 - return $type 917 -} 918 - 919 -# Returns the logon session type symbol for an integer value 920 -proc twapi::_logon_session_type_symbol {code} { 921 - variable _logon_session_type_map 922 - _logon_session_type_code interactive; # Just to init _logon_session_type_map 923 - set symbol [lindex $_logon_session_type_map $code] 924 - if {$symbol eq ""} { 925 - return $code 926 - } else { 927 - return $symbol 928 - } 929 -} 930 - 931 -proc twapi::_set_user_priv_level {username priv_level args} { 932 - 933 - array set opts [parseargs args {system.arg} -nulldefault] 934 - 935 - if {0} { 936 - # FOr some reason NetUserSetInfo cannot change priv level 937 - # Tried it separately with a simple C program. So this code 938 - # is commented out and we use group membership to achieve 939 - # the desired result 940 - # Note: - latest MSDN confirms above 941 - if {![info exists twapi::priv_level_map($priv_level)]} { 942 - error "Invalid privilege level value '$priv_level' specified. Must be one of [join [array names twapi::priv_level_map] ,]" 943 - } 944 - set priv $twapi::priv_level_map($priv_level) 945 - 946 - Twapi_NetUserSetInfo_priv $opts(system) $username $priv 947 - } else { 948 - # Don't hardcode group names - reverse map SID's instead for 949 - # non-English systems. Also note that since 950 - # we might be lowering privilege level, we have to also 951 - # remove from higher privileged groups 952 - 953 - switch -exact -- $priv_level { 954 - guest { 955 - # administrators users 956 - set outgroups {S-1-5-32-544 S-1-5-32-545} 957 - # guests 958 - set ingroup S-1-5-32-546 959 - } 960 - user { 961 - # administrators 962 - set outgroups {S-1-5-32-544} 963 - # users 964 - set ingroup S-1-5-32-545 965 - } 966 - admin { 967 - set outgroups {} 968 - set ingroup S-1-5-32-544 969 - } 970 - default {error "Invalid privilege level '$priv_level'. Must be one of 'guest', 'user' or 'admin'"} 971 - } 972 - # Remove from higher priv groups 973 - foreach outgroup $outgroups { 974 - # Get the potentially localized name of the group 975 - set group [lookup_account_sid $outgroup -system $opts(system)] 976 - # Catch since may not be member of that group 977 - catch {remove_member_from_local_group $group $username -system $opts(system)} 978 - } 979 - 980 - # Get the potentially localized name of the group to be added 981 - set group [lookup_account_sid $ingroup -system $opts(system)] 982 - add_member_to_local_group $group $username -system $opts(system) 983 - } 984 -} 985 - 986 -proc twapi::_map_userinfo_flags {flags} { 987 - # UF_LOCKOUT -> 0x10, UF_ACCOUNTDISABLE -> 0x2 988 - if {$flags & 0x2} { 989 - set status disabled 990 - } elseif {$flags & 0x10} { 991 - set status locked 992 - } else { 993 - set status enabled 994 - } 995 - 996 - #define UF_TEMP_DUPLICATE_ACCOUNT 0x0100 997 - #define UF_NORMAL_ACCOUNT 0x0200 998 - #define UF_INTERDOMAIN_TRUST_ACCOUNT 0x0800 999 - #define UF_WORKSTATION_TRUST_ACCOUNT 0x1000 1000 - #define UF_SERVER_TRUST_ACCOUNT 0x2000 1001 - if {$flags & 0x0200} { 1002 - set type normal 1003 - } elseif {$flags & 0x0100} { 1004 - set type duplicate 1005 - } elseif {$flags & 0x0800} { 1006 - set type interdomain_trust 1007 - } elseif {$flags & 0x1000} { 1008 - set type workstation_trust 1009 - } elseif {$flags & 0x2000} { 1010 - set type server_trust 1011 - } else { 1012 - set type unknown 1013 - } 1014 - 1015 - set pw {} 1016 - #define UF_PASSWD_NOTREQD 0x0020 1017 - if {$flags & 0x0020} { 1018 - lappend pw not_required 1019 - } 1020 - #define UF_PASSWD_CANT_CHANGE 0x0040 1021 - if {$flags & 0x0040} { 1022 - lappend pw cannot_change 1023 - } 1024 - #define UF_ENCRYPTED_TEXT_PASSWORD_ALLOWED 0x0080 1025 - if {$flags & 0x0080} { 1026 - lappend pw encrypted_text_allowed 1027 - } 1028 - #define UF_DONT_EXPIRE_PASSWD 0x10000 1029 - if {$flags & 0x10000} { 1030 - lappend pw no_expiry 1031 - } 1032 - #define UF_SMARTCARD_REQUIRED 0x40000 1033 - if {$flags & 0x40000} { 1034 - lappend pw smartcard_required 1035 - } 1036 - #define UF_PASSWORD_EXPIRED 0x800000 1037 - if {$flags & 0x800000} { 1038 - lappend pw expired 1039 - } 1040 - 1041 - return [list -status $status -type $type -password_attrs $pw] 1042 -} 1043 - 1044 -twapi::proc* twapi::_define_user_modals {} { 1045 - struct _USER_MODALS_INFO_0 { 1046 - DWORD min_passwd_len; 1047 - DWORD max_passwd_age; 1048 - DWORD min_passwd_age; 1049 - DWORD force_logoff; 1050 - DWORD password_hist_len; 1051 - } 1052 - struct _USER_MODALS_INFO_1 { 1053 - DWORD role; 1054 - LPWSTR primary; 1055 - } 1056 - struct _USER_MODALS_INFO_2 { 1057 - LPWSTR domain_name; 1058 - PSID domain_id; 1059 - } 1060 - struct _USER_MODALS_INFO_3 { 1061 - DWORD lockout_duration; 1062 - DWORD lockout_observation_window; 1063 - DWORD lockout_threshold; 1064 - } 1065 - struct _USER_MODALS_INFO_1001 { 1066 - DWORD min_passwd_len; 1067 - } 1068 - struct _USER_MODALS_INFO_1002 { 1069 - DWORD max_passwd_age; 1070 - } 1071 - struct _USER_MODALS_INFO_1003 { 1072 - DWORD min_passwd_age; 1073 - } 1074 - struct _USER_MODALS_INFO_1004 { 1075 - DWORD force_logoff; 1076 - } 1077 - struct _USER_MODALS_INFO_1005 { 1078 - DWORD password_hist_len; 1079 - } 1080 - struct _USER_MODALS_INFO_1006 { 1081 - DWORD role; 1082 - } 1083 - struct _USER_MODALS_INFO_1007 { 1084 - LPWSTR primary; 1085 - } 1086 -} { 1087 -} 1088 - 1089 -twapi::proc* twapi::get_password_policy {{server_name ""}} { 1090 - _define_user_modals 1091 -} { 1092 - set result [NetUserModalsGet $server_name 0 [_USER_MODALS_INFO_0]] 1093 - dict with result { 1094 - if {$force_logoff == 4294967295 || $force_logoff == -1} { 1095 - set force_logoff never 1096 - } 1097 - if {$max_passwd_age == 4294967295 || $max_passwd_age == -1} { 1098 - set max_passwd_age none 1099 - } 1100 - } 1101 - return $result 1102 -} 1103 - 1104 -# TBD - doc & test 1105 -twapi::proc* twapi::get_system_role {{server_name ""}} { 1106 - _define_user_modals 1107 -} { 1108 - set result [NetUserModalsGet $server_name 1 [_USER_MODALS_INFO_1]] 1109 - dict set result role [dict* { 1110 - 0 standalone 1 member 2 backup 3 primary 1111 - } [dict get $result role]] 1112 - return $result 1113 -} 1114 - 1115 -# TBD - doc & test 1116 -twapi::proc* twapi::get_system_domain {{server_name ""}} { 1117 - _define_user_modals 1118 -} { 1119 - return [NetUserModalsGet $server_name 2 [_USER_MODALS_INFO_2]] 1120 -} 1121 - 1122 -twapi::proc* twapi::get_lockout_policy {{server_name ""}} { 1123 - _define_user_modals 1124 -} { 1125 - return [NetUserModalsGet $server_name 3 [_USER_MODALS_INFO_3]] 1126 -} 1127 - 1128 -# TBD - doc & test 1129 -twapi::proc* twapi::set_password_policy {name val {server_name ""}} { 1130 - _define_user_modals 1131 -} { 1132 - switch -exact $name { 1133 - min_passwd_len { 1134 - NetUserModalsSet $server_name 1001 [_USER_MODALS_INFO_1001 $val] 1135 - } 1136 - max_passwd_age { 1137 - if {$val eq "none"} { 1138 - set val 4294967295 1139 - } 1140 - NetUserModalsSet $server_name 1002 [_USER_MODALS_INFO_1002 $val] 1141 - } 1142 - min_passwd_age { 1143 - NetUserModalsSet $server_name 1003 [_USER_MODALS_INFO_1003 $val] 1144 - } 1145 - force_logoff { 1146 - if {$val eq "never"} { 1147 - set val 4294967295 1148 - } 1149 - NetUserModalsSet $server_name 1004 [_USER_MODALS_INFO_1004 $val] 1150 - } 1151 - password_hist_len { 1152 - NetUserModalsSet $server_name 1005 [_USER_MODALS_INFO_1005 $val] 1153 - } 1154 - } 1155 -} 1156 - 1157 -# TBD - doc & test 1158 -twapi::proc* twapi::set_lockout_policy {duration observe_window threshold {server_name ""}} { 1159 - _define_user_modals 1160 -} { 1161 - NetUserModalsSet $server_name 3 [_USER_MODALS_INFO_3 $duration $observe_window $threshold] 1162 -}
Deleted winlibs/twapi/adsi.tcl.
1 -# 2 -# Copyright (c) 2010-2012, Ashok P. Nadkarni 3 -# All rights reserved. 4 -# 5 -# See the file LICENSE for license 6 - 7 -# ADSI routines 8 - 9 -# TBD - document 10 -proc twapi::adsi_translate_name {name to {from 0}} { 11 - set map { 12 - unknown 0 fqdn 1 samcompatible 2 display 3 uniqueid 6 13 - canonical 7 userprincipal 8 canonicalex 9 serviceprincipal 10 14 - dnsdomain 12 15 - } 16 - if {! [string is integer -strict $to]} { 17 - set to [dict get $map $to] 18 - if {$to == 0} { 19 - error "'unknown' is not a valid target format." 20 - } 21 - } 22 - 23 - if {! [string is integer -strict $from]} { 24 - set from [dict get $map $from] 25 - } 26 - 27 - return [TranslateName $name $from $to] 28 -}
Deleted winlibs/twapi/apputil.tcl.
1 -# 2 -# Copyright (c) 2003-2012, Ashok P. Nadkarni 3 -# All rights reserved. 4 -# 5 -# See the file LICENSE for license 6 - 7 -namespace eval twapi {} 8 - 9 -# Get the command line 10 -proc twapi::get_command_line {} { 11 - return [GetCommandLineW] 12 -} 13 - 14 -# Parse the command line 15 -proc twapi::get_command_line_args {cmdline} { 16 - # Special check for empty line. CommandLinetoArgv returns process 17 - # exe name in this case. 18 - if {[string length $cmdline] == 0} { 19 - return [list ] 20 - } 21 - return [CommandLineToArgv $cmdline] 22 -} 23 - 24 -# Read an ini file int 25 -proc twapi::read_inifile_key {section key args} { 26 - array set opts [parseargs args { 27 - {default.arg ""} 28 - inifile.arg 29 - } -maxleftover 0] 30 - 31 - if {[info exists opts(inifile)]} { 32 - set values [read_inifile_section $section -inifile $opts(inifile)] 33 - } else { 34 - set values [read_inifile_section $section] 35 - } 36 - 37 - # Cannot use kl_get or arrays here because we want case insensitive compare 38 - foreach {k val} $values { 39 - if {[string equal -nocase $key $k]} { 40 - return $val 41 - } 42 - } 43 - return $opts(default) 44 -} 45 - 46 -# Write an ini file string 47 -proc twapi::write_inifile_key {section key value args} { 48 - array set opts [parseargs args { 49 - inifile.arg 50 - } -maxleftover 0] 51 - 52 - if {[info exists opts(inifile)]} { 53 - WritePrivateProfileString $section $key $value $opts(inifile) 54 - } else { 55 - WriteProfileString $section $key $value 56 - } 57 -} 58 - 59 -# Delete an ini file string 60 -proc twapi::delete_inifile_key {section key args} { 61 - array set opts [parseargs args { 62 - inifile.arg 63 - } -maxleftover 0] 64 - 65 - if {[info exists opts(inifile)]} { 66 - WritePrivateProfileString $section $key $twapi::nullptr $opts(inifile) 67 - } else { 68 - WriteProfileString $section $key $twapi::nullptr 69 - } 70 -} 71 - 72 -# Get names of the sections in an inifile 73 -proc twapi::read_inifile_section_names {args} { 74 - array set opts [parseargs args { 75 - inifile.arg 76 - } -nulldefault -maxleftover 0] 77 - 78 - return [GetPrivateProfileSectionNames $opts(inifile)] 79 -} 80 - 81 -# Get keys and values in a section in an inifile 82 -proc twapi::read_inifile_section {section args} { 83 - array set opts [parseargs args { 84 - inifile.arg 85 - } -nulldefault -maxleftover 0] 86 - 87 - set result [list ] 88 - foreach line [GetPrivateProfileSection $section $opts(inifile)] { 89 - set pos [string first "=" $line] 90 - if {$pos >= 0} { 91 - lappend result [string range $line 0 [expr {$pos-1}]] [string range $line [incr pos] end] 92 - } 93 - } 94 - return $result 95 -} 96 - 97 - 98 -# Delete an ini file section 99 -proc twapi::delete_inifile_section {section args} { 100 - variable nullptr 101 - 102 - array set opts [parseargs args { 103 - inifile.arg 104 - }] 105 - 106 - if {[info exists opts(inifile)]} { 107 - WritePrivateProfileString $section $nullptr $nullptr $opts(inifile) 108 - } else { 109 - WriteProfileString $section $nullptr $nullptr 110 - } 111 -} 112 - 113 - 114 -
Deleted winlibs/twapi/base.tcl.
1 -# 2 -# Copyright (c) 2012-2014, Ashok P. Nadkarni 3 -# All rights reserved. 4 -# 5 -# See the file LICENSE for license 6 - 7 -# Commands in twapi_base module 8 - 9 -namespace eval twapi { 10 - # Map of Sid integer type to Sid type name 11 - array set sid_type_names { 12 - 1 user 13 - 2 group 14 - 3 domain 15 - 4 alias 16 - 5 wellknowngroup 17 - 6 deletedaccount 18 - 7 invalid 19 - 8 unknown 20 - 9 computer 21 - 10 label 22 - } 23 - 24 - # Cache mapping account names to SIDs. Dict keyed by system and name 25 - variable _name_to_sid_cache {} 26 - 27 - # Cache mapping SIDs to account names. Dict keyed by system and SID 28 - variable _sid_to_name_cache {} 29 - 30 -} 31 - 32 - 33 - 34 -# Return major minor servicepack as a quad list 35 -proc twapi::get_os_version {} { 36 - array set verinfo [GetVersionEx] 37 - return [list $verinfo(dwMajorVersion) $verinfo(dwMinorVersion) \ 38 - $verinfo(wServicePackMajor) $verinfo(wServicePackMinor)] 39 -} 40 - 41 -# Returns true if the OS version is at least $major.$minor.$sp 42 -proc twapi::min_os_version {major {minor 0} {spmajor 0} {spminor 0}} { 43 - lassign [twapi::get_os_version] osmajor osminor osspmajor osspminor 44 - 45 - if {$osmajor > $major} {return 1} 46 - if {$osmajor < $major} {return 0} 47 - if {$osminor > $minor} {return 1} 48 - if {$osminor < $minor} {return 0} 49 - if {$osspmajor > $spmajor} {return 1} 50 - if {$osspmajor < $spmajor} {return 0} 51 - if {$osspminor > $spminor} {return 1} 52 - if {$osspminor < $spminor} {return 0} 53 - 54 - # Same version, ok 55 - return 1 56 -} 57 - 58 -# Convert a LARGE_INTEGER time value (100ns since 1601) to a formatted date 59 -# time 60 -interp alias {} twapi::large_system_time_to_secs {} twapi::large_system_time_to_secs_since_1970 61 -proc twapi::large_system_time_to_secs_since_1970 {ns100 {fraction false}} { 62 - # No. 100ns units between 1601 to 1970 = 116444736000000000 63 - set ns100_since_1970 [expr {$ns100-116444736000000000}] 64 - 65 - set secs_since_1970 [expr {$ns100_since_1970/10000000}] 66 - if {$fraction} { 67 - append secs_since_1970 .[string range $ns100 end-6 end] 68 - } 69 - return $secs_since_1970 70 -} 71 - 72 -proc twapi::secs_since_1970_to_large_system_time {secs} { 73 - # No. 100ns units between 1601 to 1970 = 116444736000000000 74 - return [expr {($secs * 10000000) + 116444736000000000}] 75 -} 76 - 77 -# Map a Windows error code to a string 78 -proc twapi::map_windows_error {code} { 79 - # Trim trailing CR/LF 80 - return [string trimright [twapi::Twapi_MapWindowsErrorToString $code] "\r\n"] 81 -} 82 - 83 -# Load given library 84 -proc twapi::load_library {path args} { 85 - array set opts [parseargs args { 86 - dontresolverefs 87 - datafile 88 - alteredpath 89 - }] 90 - 91 - set flags 0 92 - if {$opts(dontresolverefs)} { 93 - setbits flags 1; # DONT_RESOLVE_DLL_REFERENCES 94 - } 95 - if {$opts(datafile)} { 96 - setbits flags 2; # LOAD_LIBRARY_AS_DATAFILE 97 - } 98 - if {$opts(alteredpath)} { 99 - setbits flags 8; # LOAD_WITH_ALTERED_SEARCH_PATH 100 - } 101 - 102 - # LoadLibrary always wants backslashes 103 - set path [file nativename $path] 104 - return [LoadLibraryEx $path $flags] 105 -} 106 - 107 -# Free library opened with load_library 108 -proc twapi::free_library {libh} { 109 - FreeLibrary $libh 110 -} 111 - 112 -# Format message string - will raise exception if insufficient number 113 -# of arguments 114 -proc twapi::_unsafe_format_message {args} { 115 - array set opts [parseargs args { 116 - module.arg 117 - fmtstring.arg 118 - messageid.arg 119 - langid.arg 120 - params.arg 121 - includesystem 122 - ignoreinserts 123 - width.int 124 - } -nulldefault -maxleftover 0] 125 - 126 - set flags 0 127 - 128 - if {$opts(module) == ""} { 129 - if {$opts(fmtstring) == ""} { 130 - # If neither -module nor -fmtstring specified, message is formatted 131 - # from the system 132 - set opts(module) NULL 133 - setbits flags 0x1000; # FORMAT_MESSAGE_FROM_SYSTEM 134 - } else { 135 - setbits flags 0x400; # FORMAT_MESSAGE_FROM_STRING 136 - if {$opts(includesystem) || $opts(messageid) != "" || $opts(langid) != ""} { 137 - error "Options -includesystem, -messageid and -langid cannot be used with -fmtstring" 138 - } 139 - } 140 - } else { 141 - if {$opts(fmtstring) != ""} { 142 - error "Options -fmtstring and -module cannot be used together" 143 - } 144 - setbits flags 0x800; # FORMAT_MESSAGE_FROM_HMODULE 145 - if {$opts(includesystem)} { 146 - # Also include system in search 147 - setbits flags 0x1000; # FORMAT_MESSAGE_FROM_SYSTEM 148 - } 149 - } 150 - 151 - if {$opts(ignoreinserts)} { 152 - setbits flags 0x200; # FORMAT_MESSAGE_IGNORE_INSERTS 153 - } 154 - 155 - if {$opts(width) > 254} { 156 - error "Invalid value for option -width. Must be -1, 0, or a positive integer less than 255" 157 - } 158 - if {$opts(width) < 0} { 159 - # Negative width means no width restrictions 160 - set opts(width) 255; # 255 -> no restrictions 161 - } 162 - incr flags $opts(width); # Width goes in low byte of flags 163 - 164 - if {$opts(fmtstring) != ""} { 165 - return [FormatMessageFromString $flags $opts(fmtstring) $opts(params)] 166 - } else { 167 - if {![string is integer -strict $opts(messageid)]} { 168 - error "Unspecified or invalid value for -messageid option. Must be an integer value" 169 - } 170 - if {$opts(langid) == ""} { set opts(langid) 0 } 171 - if {![string is integer -strict $opts(langid)]} { 172 - error "Unspecfied or invalid value for -langid option. Must be an integer value" 173 - } 174 - 175 - # Check if $opts(module) is a file or module handle (pointer) 176 - if {[pointer? $opts(module)]} { 177 - return [FormatMessageFromModule $flags $opts(module) \ 178 - $opts(messageid) $opts(langid) $opts(params)] 179 - } else { 180 - set hmod [load_library $opts(module) -datafile] 181 - trap { 182 - set message [FormatMessageFromModule $flags $hmod \ 183 - $opts(messageid) $opts(langid) $opts(params)] 184 - } finally { 185 - free_library $hmod 186 - } 187 - return $message 188 - } 189 - } 190 -} 191 - 192 -# Format message string 193 -proc twapi::format_message {args} { 194 - array set opts [parseargs args { 195 - params.arg 196 - fmtstring.arg 197 - width.int 198 - ignoreinserts 199 - } -ignoreunknown] 200 - 201 - # TBD - document - if no params specified, different from params = {} 202 - 203 - # If a format string is specified, other options do not matter 204 - # except for -width. In that case, we do not call FormatMessage 205 - # at all 206 - if {[info exists opts(fmtstring)]} { 207 - # If -width specifed, call FormatMessage 208 - if {[info exists opts(width)] && $opts(width)} { 209 - set msg [_unsafe_format_message -ignoreinserts -fmtstring $opts(fmtstring) -width $opts(width) {*}$args] 210 - } else { 211 - set msg $opts(fmtstring) 212 - } 213 - } else { 214 - # Not -fmtstring, retrieve from message file 215 - if {[info exists opts(width)]} { 216 - set msg [_unsafe_format_message -ignoreinserts -width $opts(width) {*}$args] 217 - } else { 218 - set msg [_unsafe_format_message -ignoreinserts {*}$args] 219 - } 220 - } 221 - 222 - # If we are told to ignore inserts, all done. Else replace them except 223 - # that if no param list, do not replace placeholder. This is NOT 224 - # the same as empty param list 225 - if {$opts(ignoreinserts) || ![info exists opts(params)]} { 226 - return $msg 227 - } 228 - 229 - # TBD - cache fmtstring -> indices for performance 230 - set placeholder_indices [regexp -indices -all -inline {%(?:.|(?:[1-9][0-9]?(?:![^!]+!)?))} $msg] 231 - 232 - if {[llength $placeholder_indices] == 0} { 233 - # No placeholders. 234 - return $msg 235 - } 236 - 237 - # Use of * in format specifiers will change where the actual parameters 238 - # are positioned 239 - set num_asterisks 0 240 - set msg2 "" 241 - set prev_end 0 242 - foreach placeholder $placeholder_indices { 243 - lassign $placeholder start end 244 - # Append the stuff between previous placeholder and this one 245 - append msg2 [string range $msg $prev_end [expr {$start-1}]] 246 - set spec [string range $msg $start+1 $end] 247 - switch -exact -- [string index $spec 0] { 248 - % { append msg2 % } 249 - r { append msg2 \r } 250 - n { append msg2 \n } 251 - t { append msg2 \t } 252 - 0 { 253 - # No-op - %0 means to not add trailing newline 254 - } 255 - default { 256 - if {! [string is integer -strict [string index $spec 0]]} { 257 - # Not a insert parameter. Just append the character 258 - append msg2 $spec 259 - } else { 260 - # Insert parameter 261 - set fmt "" 262 - scan $spec %d%s param_index fmt 263 - # Note params are numbered starting with 1 264 - incr param_index -1 265 - # Format spec, if present, is enclosed in !. Get rid of them 266 - set fmt [string trim $fmt "!"] 267 - if {$fmt eq ""} { 268 - # No fmt spec 269 - } else { 270 - # Since everything is a string in Tcl, we happily 271 - # do not have to worry about type. However, the 272 - # format spec could have * specifiers which will 273 - # change the parameter indexing for subsequent 274 - # arguments 275 - incr num_asterisks [expr {[llength [split $fmt *]]-1}] 276 - incr param_index $num_asterisks 277 - } 278 - # TBD - we ignore the actual format type 279 - append msg2 [lindex $opts(params) $param_index] 280 - } 281 - } 282 - } 283 - set prev_end [incr end] 284 - } 285 - append msg2 [string range $msg $prev_end end] 286 - return $msg2 287 -} 288 - 289 -# Revert to process token. In base package because used across many modules 290 -proc twapi::revert_to_self {{opt ""}} { 291 - RevertToSelf 292 -} 293 - 294 -# For backward compatibility 295 -interp alias {} twapi::expand_environment_strings {} twapi::expand_environment_vars 296 - 297 -proc twapi::_init_security_defs {} { 298 - variable security_defs 299 - 300 - # NOTE : the access definitions for those types that are included here 301 - # have been updated as of Windows 8. 302 - array set security_defs { 303 - 304 - TOKEN_ASSIGN_PRIMARY 0x00000001 305 - TOKEN_DUPLICATE 0x00000002 306 - TOKEN_IMPERSONATE 0x00000004 307 - TOKEN_QUERY 0x00000008 308 - TOKEN_QUERY_SOURCE 0x00000010 309 - TOKEN_ADJUST_PRIVILEGES 0x00000020 310 - TOKEN_ADJUST_GROUPS 0x00000040 311 - TOKEN_ADJUST_DEFAULT 0x00000080 312 - TOKEN_ADJUST_SESSIONID 0x00000100 313 - 314 - TOKEN_ALL_ACCESS_WINNT 0x000F00FF 315 - TOKEN_ALL_ACCESS_WIN2K 0x000F01FF 316 - TOKEN_ALL_ACCESS 0x000F01FF 317 - TOKEN_READ 0x00020008 318 - TOKEN_WRITE 0x000200E0 319 - TOKEN_EXECUTE 0x00020000 320 - 321 - SYSTEM_MANDATORY_LABEL_NO_WRITE_UP 0x1 322 - SYSTEM_MANDATORY_LABEL_NO_READ_UP 0x2 323 - SYSTEM_MANDATORY_LABEL_NO_EXECUTE_UP 0x4 324 - 325 - ACL_REVISION 2 326 - ACL_REVISION_DS 4 327 - 328 - ACCESS_MAX_MS_V2_ACE_TYPE 0x3 329 - ACCESS_MAX_MS_V3_ACE_TYPE 0x4 330 - ACCESS_MAX_MS_V4_ACE_TYPE 0x8 331 - ACCESS_MAX_MS_V5_ACE_TYPE 0x11 332 - 333 - STANDARD_RIGHTS_REQUIRED 0x000F0000 334 - STANDARD_RIGHTS_READ 0x00020000 335 - STANDARD_RIGHTS_WRITE 0x00020000 336 - STANDARD_RIGHTS_EXECUTE 0x00020000 337 - STANDARD_RIGHTS_ALL 0x001F0000 338 - SPECIFIC_RIGHTS_ALL 0x0000FFFF 339 - 340 - GENERIC_READ 0x80000000 341 - GENERIC_WRITE 0x40000000 342 - GENERIC_EXECUTE 0x20000000 343 - GENERIC_ALL 0x10000000 344 - 345 - SERVICE_QUERY_CONFIG 0x00000001 346 - SERVICE_CHANGE_CONFIG 0x00000002 347 - SERVICE_QUERY_STATUS 0x00000004 348 - SERVICE_ENUMERATE_DEPENDENTS 0x00000008 349 - SERVICE_START 0x00000010 350 - SERVICE_STOP 0x00000020 351 - SERVICE_PAUSE_CONTINUE 0x00000040 352 - SERVICE_INTERROGATE 0x00000080 353 - SERVICE_USER_DEFINED_CONTROL 0x00000100 354 - SERVICE_ALL_ACCESS 0x000F01FF 355 - 356 - SC_MANAGER_CONNECT 0x00000001 357 - SC_MANAGER_CREATE_SERVICE 0x00000002 358 - SC_MANAGER_ENUMERATE_SERVICE 0x00000004 359 - SC_MANAGER_LOCK 0x00000008 360 - SC_MANAGER_QUERY_LOCK_STATUS 0x00000010 361 - SC_MANAGER_MODIFY_BOOT_CONFIG 0x00000020 362 - SC_MANAGER_ALL_ACCESS 0x000F003F 363 - 364 - KEY_QUERY_VALUE 0x00000001 365 - KEY_SET_VALUE 0x00000002 366 - KEY_CREATE_SUB_KEY 0x00000004 367 - KEY_ENUMERATE_SUB_KEYS 0x00000008 368 - KEY_NOTIFY 0x00000010 369 - KEY_CREATE_LINK 0x00000020 370 - KEY_WOW64_32KEY 0x00000200 371 - KEY_WOW64_64KEY 0x00000100 372 - KEY_WOW64_RES 0x00000300 373 - KEY_READ 0x00020019 374 - KEY_WRITE 0x00020006 375 - KEY_EXECUTE 0x00020019 376 - KEY_ALL_ACCESS 0x000F003F 377 - 378 - POLICY_VIEW_LOCAL_INFORMATION 0x00000001 379 - POLICY_VIEW_AUDIT_INFORMATION 0x00000002 380 - POLICY_GET_PRIVATE_INFORMATION 0x00000004 381 - POLICY_TRUST_ADMIN 0x00000008 382 - POLICY_CREATE_ACCOUNT 0x00000010 383 - POLICY_CREATE_SECRET 0x00000020 384 - POLICY_CREATE_PRIVILEGE 0x00000040 385 - POLICY_SET_DEFAULT_QUOTA_LIMITS 0x00000080 386 - POLICY_SET_AUDIT_REQUIREMENTS 0x00000100 387 - POLICY_AUDIT_LOG_ADMIN 0x00000200 388 - POLICY_SERVER_ADMIN 0x00000400 389 - POLICY_LOOKUP_NAMES 0x00000800 390 - POLICY_NOTIFICATION 0x00001000 391 - POLICY_READ 0X00020006 392 - POLICY_WRITE 0X000207F8 393 - POLICY_EXECUTE 0X00020801 394 - POLICY_ALL_ACCESS 0X000F0FFF 395 - 396 - DESKTOP_READOBJECTS 0x0001 397 - DESKTOP_CREATEWINDOW 0x0002 398 - DESKTOP_CREATEMENU 0x0004 399 - DESKTOP_HOOKCONTROL 0x0008 400 - DESKTOP_JOURNALRECORD 0x0010 401 - DESKTOP_JOURNALPLAYBACK 0x0020 402 - DESKTOP_ENUMERATE 0x0040 403 - DESKTOP_WRITEOBJECTS 0x0080 404 - DESKTOP_SWITCHDESKTOP 0x0100 405 - 406 - WINSTA_ENUMDESKTOPS 0x0001 407 - WINSTA_READATTRIBUTES 0x0002 408 - WINSTA_ACCESSCLIPBOARD 0x0004 409 - WINSTA_CREATEDESKTOP 0x0008 410 - WINSTA_WRITEATTRIBUTES 0x0010 411 - WINSTA_ACCESSGLOBALATOMS 0x0020 412 - WINSTA_EXITWINDOWS 0x0040 413 - WINSTA_ENUMERATE 0x0100 414 - WINSTA_READSCREEN 0x0200 415 - WINSTA_ALL_ACCESS 0x37f 416 - 417 - PROCESS_TERMINATE 0x0001 418 - PROCESS_CREATE_THREAD 0x0002 419 - PROCESS_SET_SESSIONID 0x0004 420 - PROCESS_VM_OPERATION 0x0008 421 - PROCESS_VM_READ 0x0010 422 - PROCESS_VM_WRITE 0x0020 423 - PROCESS_DUP_HANDLE 0x0040 424 - PROCESS_CREATE_PROCESS 0x0080 425 - PROCESS_SET_QUOTA 0x0100 426 - PROCESS_SET_INFORMATION 0x0200 427 - PROCESS_QUERY_INFORMATION 0x0400 428 - PROCESS_SUSPEND_RESUME 0x0800 429 - 430 - THREAD_TERMINATE 0x00000001 431 - THREAD_SUSPEND_RESUME 0x00000002 432 - THREAD_GET_CONTEXT 0x00000008 433 - THREAD_SET_CONTEXT 0x00000010 434 - THREAD_SET_INFORMATION 0x00000020 435 - THREAD_QUERY_INFORMATION 0x00000040 436 - THREAD_SET_THREAD_TOKEN 0x00000080 437 - THREAD_IMPERSONATE 0x00000100 438 - THREAD_DIRECT_IMPERSONATION 0x00000200 439 - THREAD_SET_LIMITED_INFORMATION 0x00000400 440 - THREAD_QUERY_LIMITED_INFORMATION 0x00000800 441 - 442 - EVENT_MODIFY_STATE 0x00000002 443 - EVENT_ALL_ACCESS 0x001F0003 444 - 445 - SEMAPHORE_MODIFY_STATE 0x00000002 446 - SEMAPHORE_ALL_ACCESS 0x001F0003 447 - 448 - MUTANT_QUERY_STATE 0x00000001 449 - MUTANT_ALL_ACCESS 0x001F0001 450 - 451 - MUTEX_MODIFY_STATE 0x00000001 452 - MUTEX_ALL_ACCESS 0x001F0001 453 - 454 - TIMER_QUERY_STATE 0x00000001 455 - TIMER_MODIFY_STATE 0x00000002 456 - TIMER_ALL_ACCESS 0x001F0003 457 - 458 - FILE_READ_DATA 0x00000001 459 - FILE_LIST_DIRECTORY 0x00000001 460 - FILE_WRITE_DATA 0x00000002 461 - FILE_ADD_FILE 0x00000002 462 - FILE_APPEND_DATA 0x00000004 463 - FILE_ADD_SUBDIRECTORY 0x00000004 464 - FILE_CREATE_PIPE_INSTANCE 0x00000004 465 - FILE_READ_EA 0x00000008 466 - FILE_WRITE_EA 0x00000010 467 - FILE_EXECUTE 0x00000020 468 - FILE_TRAVERSE 0x00000020 469 - FILE_DELETE_CHILD 0x00000040 470 - FILE_READ_ATTRIBUTES 0x00000080 471 - FILE_WRITE_ATTRIBUTES 0x00000100 472 - 473 - FILE_ALL_ACCESS 0x001F01FF 474 - FILE_GENERIC_READ 0x00120089 475 - FILE_GENERIC_WRITE 0x00120116 476 - FILE_GENERIC_EXECUTE 0x001200A0 477 - 478 - DELETE 0x00010000 479 - READ_CONTROL 0x00020000 480 - WRITE_DAC 0x00040000 481 - WRITE_OWNER 0x00080000 482 - SYNCHRONIZE 0x00100000 483 - 484 - COM_RIGHTS_EXECUTE 1 485 - COM_RIGHTS_EXECUTE_LOCAL 2 486 - COM_RIGHTS_EXECUTE_REMOTE 4 487 - COM_RIGHTS_ACTIVATE_LOCAL 8 488 - COM_RIGHTS_ACTIVATE_REMOTE 16 489 - } 490 - 491 - if {[min_os_version 6]} { 492 - array set security_defs { 493 - PROCESS_QUERY_LIMITED_INFORMATION 0x00001000 494 - PROCESS_ALL_ACCESS 0x001fffff 495 - THREAD_ALL_ACCESS 0x001fffff 496 - } 497 - } else { 498 - array set security_defs { 499 - PROCESS_ALL_ACCESS 0x001f0fff 500 - THREAD_ALL_ACCESS 0x001f03ff 501 - } 502 - } 503 - 504 - # Make next call a no-op 505 - proc _init_security_defs {} {} 506 -} 507 - 508 -# Map a set of access right symbols to a flag. Concatenates 509 -# all the arguments, and then OR's the individual elements. Each 510 -# element may either be a integer or one of the access rights 511 -proc twapi::_access_rights_to_mask {args} { 512 - _init_security_defs 513 - 514 - proc _access_rights_to_mask args { 515 - variable security_defs 516 - set rights 0 517 - foreach right [concat {*}$args] { 518 - # The mandatory label access rights are not in security_defs 519 - # because we do not want them to mess up the int->name mapping 520 - # for DACL's 521 - set right [dict* { 522 - no_write_up 1 523 - system_mandatory_label_no_write_up 1 524 - no_read_up 2 525 - system_mandatory_label_no_read_up 2 526 - no_execute_up 4 527 - system_mandatory_label_no_execute_up 4 528 - } $right] 529 - if {![string is integer $right]} { 530 - if {[catch {set right $security_defs([string toupper $right])}]} { 531 - error "Invalid access right symbol '$right'" 532 - } 533 - } 534 - set rights [expr {$rights | $right}] 535 - } 536 - return $rights 537 - } 538 - return [_access_rights_to_mask {*}$args] 539 -} 540 - 541 - 542 -# Map an access mask to a set of rights 543 -proc twapi::_access_mask_to_rights {access_mask {type ""}} { 544 - _init_security_defs 545 - 546 - proc _access_mask_to_rights {access_mask {type ""}} { 547 - variable security_defs 548 - 549 - set rights [list ] 550 - 551 - if {$type eq "mandatory_label"} { 552 - if {$access_mask & 1} { 553 - lappend rights system_mandatory_label_no_write_up 554 - } 555 - if {$access_mask & 2} { 556 - lappend rights system_mandatory_label_no_read_up 557 - } 558 - if {$access_mask & 4} { 559 - lappend rights system_mandatory_label_no_execute_up 560 - } 561 - return $rights 562 - } 563 - 564 - # The returned list will include rights that map to multiple bits 565 - # as well as the individual bits. We first add the multiple bits 566 - # and then the individual bits (since we clear individual bits 567 - # after adding) 568 - 569 - # 570 - # Check standard multiple bit masks 571 - # 572 - foreach x {STANDARD_RIGHTS_REQUIRED STANDARD_RIGHTS_READ STANDARD_RIGHTS_WRITE STANDARD_RIGHTS_EXECUTE STANDARD_RIGHTS_ALL SPECIFIC_RIGHTS_ALL} { 573 - if {($security_defs($x) & $access_mask) == $security_defs($x)} { 574 - lappend rights [string tolower $x] 575 - } 576 - } 577 - 578 - # 579 - # Check type specific multiple bit masks. 580 - # 581 - 582 - set type_mask_map { 583 - file {FILE_ALL_ACCESS FILE_GENERIC_READ FILE_GENERIC_WRITE FILE_GENERIC_EXECUTE} 584 - process {PROCESS_ALL_ACCESS} 585 - pipe {FILE_ALL_ACCESS} 586 - policy {POLICY_READ POLICY_WRITE POLICY_EXECUTE POLICY_ALL_ACCESS} 587 - registry {KEY_READ KEY_WRITE KEY_EXECUTE KEY_ALL_ACCESS} 588 - service {SERVICE_ALL_ACCESS} 589 - thread {THREAD_ALL_ACCESS} 590 - token {TOKEN_READ TOKEN_WRITE TOKEN_EXECUTE TOKEN_ALL_ACCESS} 591 - desktop {} 592 - winsta {WINSTA_ALL_ACCESS} 593 - } 594 - if {[dict exists $type_mask_map $type]} { 595 - foreach x [dict get $type_mask_map $type] { 596 - if {($security_defs($x) & $access_mask) == $security_defs($x)} { 597 - lappend rights [string tolower $x] 598 - } 599 - } 600 - } 601 - 602 - # 603 - # OK, now map individual bits 604 - 605 - # First map the common bits 606 - foreach x {DELETE READ_CONTROL WRITE_DAC WRITE_OWNER SYNCHRONIZE} { 607 - if {$security_defs($x) & $access_mask} { 608 - lappend rights [string tolower $x] 609 - resetbits access_mask $security_defs($x) 610 - } 611 - } 612 - 613 - # Then the generic bits 614 - foreach x {GENERIC_READ GENERIC_WRITE GENERIC_EXECUTE GENERIC_ALL} { 615 - if {$security_defs($x) & $access_mask} { 616 - lappend rights [string tolower $x] 617 - resetbits access_mask $security_defs($x) 618 - } 619 - } 620 - 621 - # Then the type specific 622 - set type_mask_map { 623 - file { FILE_READ_DATA FILE_WRITE_DATA FILE_APPEND_DATA 624 - FILE_READ_EA FILE_WRITE_EA FILE_EXECUTE 625 - FILE_DELETE_CHILD FILE_READ_ATTRIBUTES 626 - FILE_WRITE_ATTRIBUTES } 627 - pipe { FILE_READ_DATA FILE_WRITE_DATA FILE_CREATE_PIPE_INSTANCE 628 - FILE_READ_ATTRIBUTES FILE_WRITE_ATTRIBUTES } 629 - service { SERVICE_QUERY_CONFIG SERVICE_CHANGE_CONFIG 630 - SERVICE_QUERY_STATUS SERVICE_ENUMERATE_DEPENDENTS 631 - SERVICE_START SERVICE_STOP SERVICE_PAUSE_CONTINUE 632 - SERVICE_INTERROGATE SERVICE_USER_DEFINED_CONTROL } 633 - registry { KEY_QUERY_VALUE KEY_SET_VALUE KEY_CREATE_SUB_KEY 634 - KEY_ENUMERATE_SUB_KEYS KEY_NOTIFY KEY_CREATE_LINK 635 - KEY_WOW64_32KEY KEY_WOW64_64KEY KEY_WOW64_RES } 636 - policy { POLICY_VIEW_LOCAL_INFORMATION POLICY_VIEW_AUDIT_INFORMATION 637 - POLICY_GET_PRIVATE_INFORMATION POLICY_TRUST_ADMIN 638 - POLICY_CREATE_ACCOUNT POLICY_CREATE_SECRET 639 - POLICY_CREATE_PRIVILEGE POLICY_SET_DEFAULT_QUOTA_LIMITS 640 - POLICY_SET_AUDIT_REQUIREMENTS POLICY_AUDIT_LOG_ADMIN 641 - POLICY_SERVER_ADMIN POLICY_LOOKUP_NAMES } 642 - process { PROCESS_TERMINATE PROCESS_CREATE_THREAD 643 - PROCESS_SET_SESSIONID PROCESS_VM_OPERATION 644 - PROCESS_VM_READ PROCESS_VM_WRITE PROCESS_DUP_HANDLE 645 - PROCESS_CREATE_PROCESS PROCESS_SET_QUOTA 646 - PROCESS_SET_INFORMATION PROCESS_QUERY_INFORMATION 647 - PROCESS_SUSPEND_RESUME} 648 - thread { THREAD_TERMINATE THREAD_SUSPEND_RESUME 649 - THREAD_GET_CONTEXT THREAD_SET_CONTEXT 650 - THREAD_SET_INFORMATION THREAD_QUERY_INFORMATION 651 - THREAD_SET_THREAD_TOKEN THREAD_IMPERSONATE 652 - THREAD_DIRECT_IMPERSONATION 653 - THREAD_SET_LIMITED_INFORMATION 654 - THREAD_QUERY_LIMITED_INFORMATION } 655 - token { TOKEN_ASSIGN_PRIMARY TOKEN_DUPLICATE TOKEN_IMPERSONATE 656 - TOKEN_QUERY TOKEN_QUERY_SOURCE TOKEN_ADJUST_PRIVILEGES 657 - TOKEN_ADJUST_GROUPS TOKEN_ADJUST_DEFAULT TOKEN_ADJUST_SESSIONID } 658 - desktop { DESKTOP_READOBJECTS DESKTOP_CREATEWINDOW 659 - DESKTOP_CREATEMENU DESKTOP_HOOKCONTROL 660 - DESKTOP_JOURNALRECORD DESKTOP_JOURNALPLAYBACK 661 - DESKTOP_ENUMERATE DESKTOP_WRITEOBJECTS DESKTOP_SWITCHDESKTOP } 662 - windowstation { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES 663 - WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP 664 - WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS 665 - WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN } 666 - winsta { WINSTA_ENUMDESKTOPS WINSTA_READATTRIBUTES 667 - WINSTA_ACCESSCLIPBOARD WINSTA_CREATEDESKTOP 668 - WINSTA_WRITEATTRIBUTES WINSTA_ACCESSGLOBALATOMS 669 - WINSTA_EXITWINDOWS WINSTA_ENUMERATE WINSTA_READSCREEN } 670 - com { COM_RIGHTS_EXECUTE COM_RIGHTS_EXECUTE_LOCAL 671 - COM_RIGHTS_EXECUTE_REMOTE COM_RIGHTS_ACTIVATE_LOCAL 672 - COM_RIGHTS_ACTIVATE_REMOTE 673 - } 674 - } 675 - 676 - if {[min_os_version 6]} { 677 - dict lappend type_mask_map process PROCESS_QUERY_LIMITED_INFORMATION 678 - } 679 - 680 - if {[dict exists $type_mask_map $type]} { 681 - foreach x [dict get $type_mask_map $type] { 682 - if {$security_defs($x) & $access_mask} { 683 - lappend rights [string tolower $x] 684 - # Reset the bit so is it not included in unknown bits below 685 - resetbits access_mask $security_defs($x) 686 - } 687 - } 688 - } 689 - 690 - # Finally add left over bits if any 691 - for {set i 0} {$i < 32} {incr i} { 692 - set x [expr {1 << $i}] 693 - if {$access_mask & $x} { 694 - lappend rights [hex32 $x] 695 - } 696 - } 697 - 698 - return $rights 699 - } 700 - 701 - return [_access_mask_to_rights $access_mask $type] 702 -} 703 - 704 -# Map the symbolic CreateDisposition parameter of CreateFile to integer values 705 -proc twapi::_create_disposition_to_code {sym} { 706 - if {[string is integer -strict $sym]} { 707 - return $sym 708 - } 709 - # CREATE_NEW 1 710 - # CREATE_ALWAYS 2 711 - # OPEN_EXISTING 3 712 - # OPEN_ALWAYS 4 713 - # TRUNCATE_EXISTING 5 714 - return [dict get { 715 - create_new 1 716 - create_always 2 717 - open_existing 3 718 - open_always 4 719 - truncate_existing 5} $sym] 720 -} 721 - 722 -# Wrapper around CreateFile 723 -proc twapi::create_file {path args} { 724 - array set opts [parseargs args { 725 - {access.arg {generic_read}} 726 - {share.arg {read write delete}} 727 - {inherit.bool 0} 728 - {secd.arg ""} 729 - {createdisposition.arg open_always} 730 - {flags.int 0} 731 - {templatefile.arg NULL} 732 - } -maxleftover 0] 733 - 734 - set access_mode [_access_rights_to_mask $opts(access)] 735 - set share_mode [_share_mode_to_mask $opts(share)] 736 - set create_disposition [_create_disposition_to_code $opts(createdisposition)] 737 - return [CreateFile $path \ 738 - $access_mode \ 739 - $share_mode \ 740 - [_make_secattr $opts(secd) $opts(inherit)] \ 741 - $create_disposition \ 742 - $opts(flags) \ 743 - $opts(templatefile)] 744 -} 745 - 746 -# Map a set of share mode symbols to a flag. Concatenates 747 -# all the arguments, and then OR's the individual elements. Each 748 -# element may either be a integer or one of the share modes 749 -proc twapi::_share_mode_to_mask {modelist} { 750 - # Values correspond to FILE_SHARE_* defines 751 - return [_parse_symbolic_bitmask $modelist {read 1 write 2 delete 4}] 752 -} 753 - 754 -# Construct a security attributes structure out of a security descriptor 755 -# and inheritance. The command is here because we do not want to 756 -# have to load the twapi_security package for the common case of 757 -# null security attributes. 758 -proc twapi::_make_secattr {secd inherit} { 759 - if {$inherit} { 760 - set sec_attr [list $secd 1] 761 - } else { 762 - if {[llength $secd] == 0} { 763 - # If a security descriptor not specified, keep 764 - # all security attributes as an empty list (ie. NULL) 765 - set sec_attr [list ] 766 - } else { 767 - set sec_attr [list $secd 0] 768 - } 769 - } 770 - return $sec_attr 771 -} 772 - 773 -# Returns the sid, domain and type for an account 774 -proc twapi::lookup_account_name {name args} { 775 - variable _name_to_sid_cache 776 - 777 - # Fast path - no options specified and cached 778 - if {[llength $args] == 0 && [dict exists $_name_to_sid_cache "" $name]} { 779 - return [lindex [dict get $_name_to_sid_cache "" $name] 0] 780 - } 781 - 782 - array set opts [parseargs args \ 783 - [list all \ 784 - sid \ 785 - domain \ 786 - type \ 787 - [list system.arg ""]\ 788 - ]] 789 - 790 - if {! [dict exists $_name_to_sid_cache $opts(system) $name]} { 791 - dict set _name_to_sid_cache $opts(system) $name [LookupAccountName $opts(system) $name] 792 - } 793 - lassign [dict get $_name_to_sid_cache $opts(system) $name] sid domain type 794 - 795 - set result [list ] 796 - if {$opts(all) || $opts(domain)} { 797 - lappend result -domain $domain 798 - } 799 - if {$opts(all) || $opts(type)} { 800 - if {[info exists twapi::sid_type_names($type)]} { 801 - lappend result -type $twapi::sid_type_names($type) 802 - } else { 803 - # Could be the "logonid" dummy type we added above 804 - lappend result -type $type 805 - } 806 - } 807 - 808 - if {$opts(all) || $opts(sid)} { 809 - lappend result -sid $sid 810 - } 811 - 812 - # If no options specified, only return the sid/name 813 - if {[llength $result] == 0} { 814 - return $sid 815 - } 816 - 817 - return $result 818 -} 819 - 820 - 821 -# Returns the name, domain and type for an account 822 -proc twapi::lookup_account_sid {sid args} { 823 - variable _sid_to_name_cache 824 - 825 - # Fast path - no options specified and cached 826 - if {[llength $args] == 0 && [dict exists $_sid_to_name_cache "" $sid]} { 827 - return [lindex [dict get $_sid_to_name_cache "" $sid] 0] 828 - } 829 - 830 - array set opts [parseargs args \ 831 - [list all \ 832 - name \ 833 - domain \ 834 - type \ 835 - [list system.arg ""]\ 836 - ]] 837 - 838 - if {! [dict exists $_sid_to_name_cache $opts(system) $sid]} { 839 - # Not in cache. Need to look up 840 - 841 - # LookupAccountSid returns an error for this SID 842 - if {[is_valid_sid_syntax $sid] && 843 - [string match -nocase "S-1-5-5-*" $sid]} { 844 - set name "Logon SID" 845 - set domain "NT AUTHORITY" 846 - set type "logonid" 847 - dict set _sid_to_name_cache $opts(system) $sid [list $name $domain $type] 848 - } else { 849 - set data [LookupAccountSid $opts(system) $sid] 850 - lassign $data name domain type 851 - dict set _sid_to_name_cache $opts(system) $sid $data 852 - } 853 - } else { 854 - lassign [dict get $_sid_to_name_cache $opts(system) $sid] name domain type 855 - } 856 - 857 - 858 - set result [list ] 859 - if {$opts(all) || $opts(domain)} { 860 - lappend result -domain $domain 861 - } 862 - if {$opts(all) || $opts(type)} { 863 - if {[info exists twapi::sid_type_names($type)]} { 864 - lappend result -type $twapi::sid_type_names($type) 865 - } else { 866 - # Could be the "logonid" dummy type we added above 867 - lappend result -type $type 868 - } 869 - } 870 - 871 - if {$opts(all) || $opts(name)} { 872 - lappend result -name $name 873 - } 874 - 875 - # If no options specified, only return the sid/name 876 - if {[llength $result] == 0} { 877 - return $name 878 - } 879 - 880 - return $result 881 -} 882 - 883 -# Returns the sid for a account - may be given as a SID or name 884 -proc twapi::map_account_to_sid {account args} { 885 - array set opts [parseargs args {system.arg} -nulldefault] 886 - 887 - # Treat empty account as null SID (self) 888 - if {[string length $account] == ""} { 889 - return "" 890 - } 891 - 892 - if {[is_valid_sid_syntax $account]} { 893 - return $account 894 - } else { 895 - return [lookup_account_name $account -system $opts(system)] 896 - } 897 -} 898 - 899 - 900 -# Returns the name for a account - may be given as a SID or name 901 -proc twapi::map_account_to_name {account args} { 902 - array set opts [parseargs args {system.arg} -nulldefault] 903 - 904 - if {[is_valid_sid_syntax $account]} { 905 - return [lookup_account_sid $account -system $opts(system)] 906 - } else { 907 - # Verify whether a valid account by mapping to an sid 908 - if {[catch {map_account_to_sid $account -system $opts(system)}]} { 909 - # As a special case, change LocalSystem to SYSTEM. Some Windows 910 - # API's (such as services) return LocalSystem which cannot be 911 - # resolved by the security functions. This name is really the 912 - # same a the built-in SYSTEM 913 - if {$account == "LocalSystem"} { 914 - return "SYSTEM" 915 - } 916 - error "Unknown account '$account'" 917 - } 918 - return $account 919 - } 920 -} 921 - 922 -# Return the user account for the current process 923 -proc twapi::get_current_user {{format -samcompatible}} { 924 - 925 - set return_sid false 926 - switch -exact -- $format { 927 - -fullyqualifieddn {set format 1} 928 - -samcompatible {set format 2} 929 - -display {set format 3} 930 - -uniqueid {set format 6} 931 - -canonical {set format 7} 932 - -userprincipal {set format 8} 933 - -canonicalex {set format 9} 934 - -serviceprincipal {set format 10} 935 - -dnsdomain {set format 12} 936 - -sid {set format 2 ; set return_sid true} 937 - default { 938 - error "Unknown user name format '$format'" 939 - } 940 - } 941 - 942 - set user [GetUserNameEx $format] 943 - 944 - if {$return_sid} { 945 - return [map_account_to_sid $user] 946 - } else { 947 - return $user 948 - } 949 -} 950 - 951 -# Get a new uuid 952 -proc twapi::new_uuid {{opt ""}} { 953 - if {[string length $opt]} { 954 - if {[string equal $opt "-localok"]} { 955 - set local_ok 1 956 - } else { 957 - error "Invalid or unknown argument '$opt'" 958 - } 959 - } else { 960 - set local_ok 0 961 - } 962 - return [UuidCreate $local_ok] 963 -} 964 -proc twapi::nil_uuid {} { 965 - return [UuidCreateNil] 966 -} 967 - 968 -proc twapi::new_guid {} { 969 - return [canonicalize_guid [new_uuid]] 970 -} 971 - 972 -# Get a handle to a LSA policy. TBD - document 973 -proc twapi::get_lsa_policy_handle {args} { 974 - array set opts [parseargs args { 975 - {system.arg ""} 976 - {access.arg policy_read} 977 - } -maxleftover 0] 978 - 979 - set access [_access_rights_to_mask $opts(access)] 980 - return [Twapi_LsaOpenPolicy $opts(system) $access] 981 -} 982 - 983 -# Close a LSA policy handle. TBD - document 984 -proc twapi::close_lsa_policy_handle {h} { 985 - LsaClose $h 986 - return 987 -} 988 - 989 -# Eventlog stuff in the base package 990 - 991 -namespace eval twapi { 992 - # Keep track of event log handles - values are "r" or "w" 993 - variable eventlog_handles 994 - array set eventlog_handles {} 995 -} 996 - 997 -# Open an eventlog for reading or writing 998 -proc twapi::eventlog_open {args} { 999 - variable eventlog_handles 1000 - 1001 - array set opts [parseargs args { 1002 - system.arg 1003 - source.arg 1004 - file.arg 1005 - write 1006 - } -nulldefault -maxleftover 0] 1007 - if {$opts(source) == ""} { 1008 - # Source not specified 1009 - if {$opts(file) == ""} { 1010 - # No source or file specified, default to current event log 1011 - # using executable name as source 1012 - set opts(source) [file rootname [file tail [info nameofexecutable]]] 1013 - } else { 1014 - if {$opts(write)} { 1015 - error "Option -file may not be used with -write" 1016 - } 1017 - } 1018 - } else { 1019 - # Source explicitly specified 1020 - if {$opts(file) != ""} { 1021 - error "Option -file may not be used with -source" 1022 - } 1023 - } 1024 - 1025 - if {$opts(write)} { 1026 - set handle [RegisterEventSource $opts(system) $opts(source)] 1027 - set mode write 1028 - } else { 1029 - if {$opts(source) != ""} { 1030 - set handle [OpenEventLog $opts(system) $opts(source)] 1031 - } else { 1032 - set handle [OpenBackupEventLog $opts(system) $opts(file)] 1033 - } 1034 - set mode read 1035 - } 1036 - 1037 - set eventlog_handles($handle) $mode 1038 - return $handle 1039 -} 1040 - 1041 -# Close an event log opened for writing 1042 -proc twapi::eventlog_close {hevl} { 1043 - variable eventlog_handles 1044 - 1045 - if {[_eventlog_valid_handle $hevl read]} { 1046 - CloseEventLog $hevl 1047 - } else { 1048 - DeregisterEventSource $hevl 1049 - } 1050 - 1051 - unset eventlog_handles($hevl) 1052 -} 1053 - 1054 - 1055 -# Log an event 1056 -proc twapi::eventlog_write {hevl id args} { 1057 - _eventlog_valid_handle $hevl write raise 1058 - 1059 - array set opts [parseargs args { 1060 - {type.arg information {success error warning information auditsuccess auditfailure}} 1061 - {category.int 1} 1062 - loguser 1063 - params.arg 1064 - data.arg 1065 - } -nulldefault] 1066 - 1067 - 1068 - switch -exact -- $opts(type) { 1069 - success {set opts(type) 0} 1070 - error {set opts(type) 1} 1071 - warning {set opts(type) 2} 1072 - information {set opts(type) 4} 1073 - auditsuccess {set opts(type) 8} 1074 - auditfailure {set opts(type) 16} 1075 - default {error "Invalid value '$opts(type)' for option -type"} 1076 - } 1077 - 1078 - if {$opts(loguser)} { 1079 - set user [get_current_user -sid] 1080 - } else { 1081 - set user "" 1082 - } 1083 - 1084 - ReportEvent $hevl $opts(type) $opts(category) $id \ 1085 - $user $opts(params) $opts(data) 1086 -} 1087 - 1088 - 1089 -# Log a message 1090 -proc twapi::eventlog_log {message args} { 1091 - array set opts [parseargs args { 1092 - system.arg 1093 - source.arg 1094 - {type.arg information} 1095 - {category.int 0} 1096 - } -nulldefault] 1097 - 1098 - set hevl [eventlog_open -write -source $opts(source) -system $opts(system)] 1099 - 1100 - trap { 1101 - eventlog_write $hevl 1 -params [list $message] -type $opts(type) -category $opts(category) 1102 - } finally { 1103 - eventlog_close $hevl 1104 - } 1105 - return 1106 -} 1107 - 1108 -proc twapi::make_logon_identity {username password domain} { 1109 - if {[concealed? $password]} { 1110 - return [list $username $domain $password] 1111 - } else { 1112 - return [list $username $domain [conceal $password]] 1113 - } 1114 -} 1115 - 1116 -proc twapi::read_credentials {args} { 1117 - array set opts [parseargs args { 1118 - target.arg 1119 - winerror.int 1120 - username.arg 1121 - password.arg 1122 - persist.bool 1123 - {type.sym generic {domain 0 generic 0x40000 runas 0x80000}} 1124 - {forceui.bool 0 0x80} 1125 - {showsaveoption.bool true} 1126 - {expectconfirmation.bool 0 0x20000} 1127 - } -maxleftover 0 -nulldefault] 1128 - 1129 - if {$opts(persist) && ! $opts(expectconfirmation)} { 1130 - badargs! "Option -expectconfirmation must be specified as true if -persist is true" 1131 - } 1132 - 1133 - # 0x8 -> CREDUI_FLAGS_EXCLUDE_CERTIFICATES (needed for console) 1134 - set flags [expr {0x8 | $opts(forceui) | $opts(expectconfirmation)}] 1135 - 1136 - if {$opts(persist)} { 1137 - if {! $opts(showsaveoption)} { 1138 - incr flags 0x1000; # CREDUI_FLAGS_PERSIST 1139 - } 1140 - } else { 1141 - incr flags 0x2; # CREDUI_FLAGS_DO_NOT_PERSIST 1142 - if {$opts(showsaveoption)} { 1143 - incr flags 0x40; # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX 1144 - } 1145 - } 1146 - 1147 - incr flags $opts(type) 1148 - 1149 - return [CredUICmdLinePromptForCredentials $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags] 1150 -} 1151 - 1152 -# Prompt for a password at the console 1153 -proc twapi::credentials_dialog {args} { 1154 - array set opts [parseargs args { 1155 - target.arg 1156 - winerror.int 1157 - username.arg 1158 - password.arg 1159 - persist.bool 1160 - {type.sym generic {domain 0 generic 0x40000 runas 0x80000}} 1161 - {forceui.bool 0 0x80} 1162 - {showsaveoption.bool true} 1163 - {expectconfirmation.bool 0 0x20000} 1164 - {fillusername.bool 0 0x800} 1165 - {filllocaladmins.bool 0 0x4} 1166 - {notifyfail.bool 0 0x1} 1167 - {passwordonly.bool 0 0x200} 1168 - {requirecertificate.bool 0 0x10} 1169 - {requiresmartcard.bool 0 0x100} 1170 - {validateusername.bool 0 0x400} 1171 - {parent.arg NULL} 1172 - message.arg 1173 - caption.arg 1174 - {bitmap.arg NULL} 1175 - } -maxleftover 0 -nulldefault] 1176 - 1177 - if {$opts(persist) && ! $opts(expectconfirmation)} { 1178 - badargs! "Option -willconfirm must be specified as true if -persist is true" 1179 - } 1180 - 1181 - set flags [expr { 0x8 | $opts(forceui) | $opts(notifyfail) | $opts(expectconfirmation) | $opts(fillusername) | $opts(filllocaladmins)}] 1182 - 1183 - if {$opts(persist)} { 1184 - if {! $opts(showsaveoption)} { 1185 - incr flags 0x1000; # CREDUI_FLAGS_PERSIST 1186 - } 1187 - } else { 1188 - incr flags 0x2; # CREDUI_FLAGS_DO_NOT_PERSIST 1189 - if {$opts(showsaveoption)} { 1190 - incr flags 0x40; # CREDUI_FLAGS_SHOW_SAVE_CHECK_BOX 1191 - } 1192 - } 1193 - 1194 - incr flags $opts(type) 1195 - 1196 - return [CredUIPromptForCredentials [list $opts(parent) $opts(message) $opts(caption) $opts(bitmap)] $opts(target) NULL $opts(winerror) $opts(username) $opts(password) $opts(persist) $flags] 1197 -} 1198 - 1199 -proc twapi::confirm_credentials {target valid} { 1200 - return [CredUIConfirmCredential $target $valid] 1201 -} 1202 - 1203 -# Validate a handle for a mode. Always raises error if handle is invalid 1204 -# If handle valid but not for that mode, will raise error iff $raise_error 1205 -# is non-empty. Returns 1 if valid, 0 otherwise 1206 -proc twapi::_eventlog_valid_handle {hevl mode {raise_error ""}} { 1207 - variable eventlog_handles 1208 - if {![info exists eventlog_handles($hevl)]} { 1209 - error "Invalid event log handle '$hevl'" 1210 - } 1211 - 1212 - if {[string compare $eventlog_handles($hevl) $mode]} { 1213 - if {$raise_error != ""} { 1214 - error "Eventlog handle '$hevl' not valid for $mode" 1215 - } 1216 - return 0 1217 - } else { 1218 - return 1 1219 - } 1220 -} 1221 - 1222 -### Common disk related 1223 - 1224 -# Map bit mask to list of drive letters 1225 -proc twapi::_drivemask_to_drivelist {drivebits} { 1226 - set drives [list ] 1227 - set i 0 1228 - foreach drive {A B C D E F G H I J K L M N O P Q R S T U V W X Y Z} { 1229 - if {$drivebits == 0} break 1230 - set drivemask [expr {1 << $i}] 1231 - if {[expr {$drivebits & $drivemask}]} { 1232 - lappend drives $drive: 1233 - set drivebits [expr {$drivebits & ~ $drivemask}] 1234 - } 1235 - incr i 1236 - } 1237 - return $drives 1238 -} 1239 - 1240 -### Type casts 1241 -proc twapi::tclcast {type val} { 1242 - # Only permit these because wideInt, for example, cannot be reliably 1243 - # converted -> it can return an int instead. 1244 - set types {"" empty null int boolean double string list dict} 1245 - if {$type ni $types} { 1246 - badargs! "Bad cast to \"$type\". Must be one of: $types" 1247 - } 1248 - return [Twapi_InternalCast $type $val] 1249 -} 1250 - 1251 -if {[info commands ::lmap] eq "::lmap"} { 1252 - proc twapi::safearray {type l} { 1253 - set type [dict! { 1254 - variant "" 1255 - boolean boolean 1256 - bool boolean 1257 - int int 1258 - i4 int 1259 - double double 1260 - r8 double 1261 - string string 1262 - bstr string 1263 - } $type] 1264 - return [lmap val $l {tclcast $type $val}] 1265 - } 1266 -} else { 1267 - proc twapi::safearray {type l} { 1268 - set type [dict! { 1269 - variant "" 1270 - boolean boolean 1271 - bool boolean 1272 - int int 1273 - i4 int 1274 - double double 1275 - r8 double 1276 - string string 1277 - bstr string 1278 - } $type] 1279 - set l2 {} 1280 - foreach val $l { 1281 - lappend l2 [tclcast $type $val] 1282 - } 1283 - return $l2 1284 - } 1285 -} 1286 - 1287 -namespace eval twapi::recordarray {} 1288 - 1289 -proc twapi::recordarray::size {ra} { 1290 - return [llength [lindex $ra 1]] 1291 -} 1292 - 1293 -proc twapi::recordarray::fields {ra} { 1294 - return [lindex $ra 0] 1295 -} 1296 - 1297 -proc twapi::recordarray::index {ra row args} { 1298 - set r [lindex $ra 1 $row] 1299 - if {[llength $r] == 0} { 1300 - return $r 1301 - } 1302 - ::twapi::parseargs args { 1303 - {format.arg list {list dict}} 1304 - slice.arg 1305 - } -setvars -maxleftover 0 1306 - 1307 - set fields [lindex $ra 0] 1308 - if {[info exists slice]} { 1309 - set new_fields {} 1310 - set new_r {} 1311 - foreach field $slice { 1312 - set i [twapi::enum $fields $field] 1313 - lappend new_r [lindex $r $i] 1314 - lappend new_fields [lindex $fields $i] 1315 - } 1316 - set r $new_r 1317 - set fields $new_fields 1318 - } 1319 - 1320 - if {$format eq "list"} { 1321 - return $r 1322 - } else { 1323 - return [::twapi::twine $fields $r] 1324 - } 1325 -} 1326 - 1327 -proc twapi::recordarray::range {ra low high} { 1328 - return [list [lindex $ra 0] [lrange [lindex $ra 1] $low $high]] 1329 -} 1330 - 1331 -proc twapi::recordarray::column {ra field args} { 1332 - # TBD - time to see if a script loop would be faster 1333 - ::twapi::parseargs args { 1334 - filter.arg 1335 - } -nulldefault -maxleftover 0 -setvars 1336 - _recordarray -slice [list $field] -filter $filter -format flat $ra 1337 -} 1338 - 1339 -proc twapi::recordarray::cell {ra row field} { 1340 - return [lindex [lindex $ra 1 $row] [twapi::enum [lindex $ra 0] $field]] 1341 -} 1342 - 1343 -proc twapi::recordarray::get {ra args} { 1344 - ::twapi::parseargs args { 1345 - {format.arg list {list dict flat}} 1346 - key.arg 1347 - } -ignoreunknown -setvars 1348 - 1349 - # format & key are options just to stop them flowing down to _recordarray 1350 - # We do not pass it in 1351 - 1352 - return [_recordarray {*}$args $ra] 1353 -} 1354 - 1355 -proc twapi::recordarray::getlist {ra args} { 1356 - # key is an option just to stop in flowing down to _recordarray 1357 - # We do not pass it in 1358 - 1359 - if {[llength $args] == 0} { 1360 - return [lindex $ra 1] 1361 - } 1362 - 1363 - ::twapi::parseargs args { 1364 - {format.arg list {list dict flat}} 1365 - key.arg 1366 - } -ignoreunknown -setvars 1367 - 1368 - 1369 - return [_recordarray {*}$args -format $format $ra] 1370 -} 1371 - 1372 -proc twapi::recordarray::getdict {ra args} { 1373 - ::twapi::parseargs args { 1374 - {format.arg list {list dict}} 1375 - key.arg 1376 - } -ignoreunknown -setvars 1377 - 1378 - if {![info exists key]} { 1379 - set key [lindex $ra 0 0] 1380 - } 1381 - 1382 - # Note _recordarray has different (putting it politely) semantics 1383 - # of how -format and -key option are handled so the below might 1384 - # look a bit strange in that we pass -format as list and get 1385 - # back a dict 1386 - return [_recordarray {*}$args -format $format -key $key $ra] 1387 -} 1388 - 1389 -proc twapi::recordarray::iterate {arrayvarname ra args} { 1390 - 1391 - if {[llength $args] == 0} { 1392 - badargs! "No script supplied" 1393 - } 1394 - 1395 - set body [lindex $args end] 1396 - set args [lrange $args 0 end-1] 1397 - 1398 - upvar 1 $arrayvarname var 1399 - 1400 - # TBD - Can this be optimized by prepending a ::foreach to body 1401 - # and executing that in uplevel 1 ? 1402 - 1403 - foreach rec [getlist $ra {*}$args -format dict] { 1404 - array set var $rec 1405 - set code [catch {uplevel 1 $body} result] 1406 - switch -exact -- $code { 1407 - 0 {} 1408 - 1 { 1409 - return -errorinfo $::errorInfo -errorcode $::errorCode -code error $result 1410 - } 1411 - 3 { 1412 - return; # break 1413 - } 1414 - 4 { 1415 - # continue 1416 - } 1417 - default { 1418 - return -code $code $result 1419 - } 1420 - } 1421 - } 1422 - return 1423 -} 1424 - 1425 -proc twapi::recordarray::rename {ra renames} { 1426 - set new_fields {} 1427 - foreach field [lindex $ra 0] { 1428 - if {[dict exists $renames $field]} { 1429 - lappend new_fields [dict get $renames $field] 1430 - } else { 1431 - lappend new_fields $field 1432 - } 1433 - } 1434 - return [list $new_fields [lindex $ra 1]] 1435 -} 1436 - 1437 -proc twapi::recordarray::concat {args} { 1438 - if {[llength $args] == 0} { 1439 - return {} 1440 - } 1441 - set args [lassign $args ra] 1442 - set fields [lindex $ra 0] 1443 - set values [list [lindex $ra 1]] 1444 - set width [llength $fields] 1445 - foreach ra $args { 1446 - foreach fld1 $fields fld2 [lindex $ra 0] { 1447 - if {$fld1 ne $fld2} { 1448 - twapi::badargs! "Attempt to concat record arrays with different fields ([join $fields ,] versus [join [lindex $ra 0] ,])" 1449 - } 1450 - } 1451 - lappend values [lindex $ra 1] 1452 - } 1453 - 1454 - return [list $fields [::twapi::lconcat {*}$values]] 1455 -} 1456 - 1457 -namespace eval twapi::recordarray { 1458 - namespace export cell column concat fields get getdict getlist index iterate range rename size 1459 - namespace ensemble create 1460 -} 1461 - 1462 -# Return a suitable cstruct definition based on a C definition 1463 -proc twapi::struct {struct_name s} { 1464 - variable _struct_defs 1465 - 1466 - regsub -all {(/\*.* \*/){1,1}?} $s {} s 1467 - regsub -line -all {//.*$} $s { } s 1468 - set l {} 1469 - foreach def [split $s ";"] { 1470 - set def [string trim $def] 1471 - if {$def eq ""} continue 1472 - if {![regexp {^(.+[^[:alnum:]_])([[:alnum:]_]+)\s*(\[.+\])?$} $def -> type name array]} { 1473 - error "Invalid definition $def" 1474 - } 1475 - 1476 - set child {} 1477 - switch -regexp -matchvar matchvar -- [string trim $type] { 1478 - {^char$} {set type i1} 1479 - {^BYTE$} - 1480 - {^unsigned char$} {set type ui1} 1481 - {^short$} {set type i2} 1482 - {^WORD$} - 1483 - {^unsigned\s+short$} {set type ui2} 1484 - {^BOOLEAN$} {set type bool} 1485 - {^LONG$} - 1486 - {^int$} {set type i4} 1487 - {^UINT$} - 1488 - {^ULONG$} - 1489 - {^DWORD$} - 1490 - {^unsigned\s+int$} {set type ui4} 1491 - {^__int64$} {set type i8} 1492 - {^unsigned\s+__int64$} {set type ui8} 1493 - {^double$} {set type r8} 1494 - {^LPCSTR$} - 1495 - {^LPSTR$} - 1496 - {^char\s*\*$} {set type lpstr} 1497 - {^LPCWSTR$} - 1498 - {^LPWSTR$} - 1499 - {^WCHAR\s*\*$} {set type lpwstr} 1500 - {^HANDLE$} {set type handle} 1501 - {^PSID$} {set type psid} 1502 - {^struct\s+([[:alnum:]_]+)$} { 1503 - # Embedded struct. It should be defined already. Calling 1504 - # it with no args returns its definition but doing that 1505 - # to retrieve the definition could be a security hole 1506 - # (could be passed any Tcl command!) if unwary apps 1507 - # pass in input from unknown sources. So we explicitly 1508 - # remember definitions instead. 1509 - set child_name [lindex $matchvar 1] 1510 - if {![info exists _struct_defs($child_name)]} { 1511 - error "Unknown struct $child_name" 1512 - } 1513 - set child $_struct_defs($child_name) 1514 - set type struct 1515 - } 1516 - default {error "Unknown type $type"} 1517 - } 1518 - set count 0 1519 - if {$array ne ""} { 1520 - set count [string trim [string range $array 1 end-1]] 1521 - if {![string is integer -strict $count]} { 1522 - error "Non-integer array size" 1523 - } 1524 - } 1525 - 1526 - if {[string equal -nocase $name "cbSize"] && 1527 - $type in {i4 ui4} && $count == 0} { 1528 - set type cbsize 1529 - } 1530 - 1531 - lappend l [list $name $type $count $child] 1532 - } 1533 - 1534 - set proc_body [format { 1535 - set def %s 1536 - if {[llength $args] == 0} { 1537 - return $def 1538 - } else { 1539 - return [list $def $args] 1540 - } 1541 - } [list $l]] 1542 - uplevel 1 [list proc $struct_name args $proc_body] 1543 - set _struct_defs($struct_name) $l 1544 - return 1545 -} 1546 -
Deleted winlibs/twapi/clipboard.tcl.
1 -# 2 -# Copyright (c) 2004, 2008 Ashok P. Nadkarni 3 -# All rights reserved. 4 -# 5 -# See the file LICENSE for license 6 - 7 -# Clipboard related commands 8 - 9 -namespace eval twapi { 10 -} 11 - 12 -# Open the clipboard 13 -# TBD - why no mechanism to pass window handle to OpenClipboard? 14 -proc twapi::open_clipboard {} { 15 - OpenClipboard 0 16 -} 17 - 18 -# Close the clipboard 19 -proc twapi::close_clipboard {} { 20 - catch {CloseClipboard} 21 - return 22 -} 23 - 24 -# Empty the clipboard 25 -proc twapi::empty_clipboard {} { 26 - EmptyClipboard 27 -} 28 - 29 -# Read data from the clipboard 30 -proc twapi::read_clipboard {fmt} { 31 - # Always catch errors and close clipboard before passing exception on 32 - # Also ensure memory unlocked 33 - trap { 34 - set h [GetClipboardData $fmt] 35 - set p [GlobalLock $h] 36 - set data [Twapi_ReadMemory 1 $p 0 [GlobalSize $h]] 37 - } onerror {} { 38 - catch {close_clipboard} 39 - rethrow 40 - } finally { 41 - # If p exists, then we must have locked the handle 42 - if {[info exists p]} { 43 - GlobalUnlock $h 44 - } 45 - } 46 - return $data 47 -} 48 - 49 -# Read text data from the clipboard 50 -proc twapi::read_clipboard_text {args} { 51 - array set opts [parseargs args { 52 - {raw.bool 0} 53 - }] 54 - 55 - trap { 56 - set h [GetClipboardData 13]; # 13 -> Unicode 57 - set p [GlobalLock $h] 58 - # Read data discarding terminating null 59 - set data [Twapi_ReadMemory 3 $p 0 [GlobalSize $h] 1] 60 - if {! $opts(raw)} { 61 - set data [string map {"\r\n" "\n"} $data] 62 - } 63 - } onerror {} { 64 - catch {close_clipboard} 65 - rethrow 66 - } finally { 67 - if {[info exists p]} { 68 - GlobalUnlock $h 69 - } 70 - } 71 - 72 - return $data 73 -} 74 - 75 -# Write data to the clipboard 76 -proc twapi::write_clipboard {fmt data} { 77 - # Always catch errors and close 78 - # clipboard before passing exception on 79 - trap { 80 - # For byte arrays, string length does return correct size 81 - # (DO NOT USE string bytelength - see Tcl docs!) 82 - set len [string length $data] 83 - 84 - # Allocate global memory 85 - set mem_h [GlobalAlloc 2 $len] 86 - set mem_p [GlobalLock $mem_h] 87 - 88 - Twapi_WriteMemory 1 $mem_p 0 $len $data 89 - 90 - # The rest of this code just to ensure we do not free 91 - # memory beyond this point irrespective of error/success 92 - set h $mem_h 93 - unset mem_p mem_h 94 - GlobalUnlock $h 95 - SetClipboardData $fmt $h 96 - } onerror {} { 97 - catch {close_clipboard} 98 - rethrow 99 - } finally { 100 - if {[info exists mem_p]} { 101 - GlobalUnlock $mem_h 102 - } 103 - if {[info exists mem_h]} { 104 - GlobalFree $mem_h 105 - } 106 - } 107 - return 108 -} 109 - 110 -# Write text to the clipboard 111 -proc twapi::write_clipboard_text {data args} { 112 - array set opts [parseargs args { 113 - {raw.bool 0} 114 - }] 115 - 116 - # Always catch errors and close 117 - # clipboard before passing exception on 118 - trap { 119 - # Convert \n to \r\n leaving existing \r\n alone 120 - if {! $opts(raw)} { 121 - set data [regsub -all {(^|[^\r])\n} $data[set data ""] \\1\r\n] 122 - } 123 - 124 - set mem_size [expr {2*(1+[string length $data])}] 125 - 126 - # Allocate global memory 127 - set mem_h [GlobalAlloc 2 $mem_size] 128 - set mem_p [GlobalLock $mem_h] 129 - 130 - # 3 -> write memory as Unicode 131 - Twapi_WriteMemory 3 $mem_p 0 $mem_size $data 132 - 133 - # The rest of this code just to ensure we do not free 134 - # memory beyond this point irrespective of error/success 135 - set h $mem_h 136 - unset mem_h mem_p 137 - GlobalUnlock $h 138 - SetClipboardData 13 $h; # 13 -> Unicode format 139 - } onerror {} { 140 - catch {close_clipboard} 141 - rethrow 142 - } finally { 143 - if {[info exists mem_p]} { 144 - GlobalUnlock $mem_h 145 - } 146 - if {[info exists mem_h]} { 147 - GlobalFree $mem_h 148 - } 149 - } 150 - return 151 -} 152 - 153 -# Get current clipboard formats 154 -proc twapi::get_clipboard_formats {} { 155 - return [Twapi_EnumClipboardFormats] 156 -} 157 - 158 -# Get registered clipboard format name. Clipboard does not have to be open 159 -proc twapi::get_registered_clipboard_format_name {fmt} { 160 - return [GetClipboardFormatName $fmt] 161 -} 162 - 163 -# Register a clipboard format 164 -proc twapi::register_clipboard_format {fmt_name} { 165 - RegisterClipboardFormat $fmt_name 166 -} 167 - 168 -# Returns 1/0 depending on whether a format is on the clipboard. Clipboard 169 -# does not have to be open 170 -proc twapi::clipboard_format_available {fmt} { 171 - return [IsClipboardFormatAvailable $fmt] 172 -} 173 - 174 - 175 - 176 -# Start monitoring of the clipboard 177 -proc twapi::_clipboard_handler {} { 178 - variable _clipboard_monitors 179 - 180 - if {![info exists _clipboard_monitors] || 181 - [llength $_clipboard_monitors] == 0} { 182 - return; # Not an error, could have deleted while already queued 183 - } 184 - 185 - foreach {id script} $_clipboard_monitors { 186 - set code [catch {uplevel #0 $script} msg] 187 - if {$code == 1} { 188 - # Error - put in background but we do not abort 189 - after 0 [list error $msg $::errorInfo $::errorCode] 190 - } 191 - } 192 - return 193 -} 194 - 195 -proc twapi::start_clipboard_monitor {script} { 196 - variable _clipboard_monitors 197 - 198 - set id "clip#[TwapiId]" 199 - if {![info exists _clipboard_monitors] || 200 - [llength $_clipboard_monitors] == 0} { 201 - # No clipboard monitoring in progress. Start it 202 - Twapi_ClipboardMonitorStart 203 - } 204 - 205 - lappend _clipboard_monitors $id $script 206 - return $id 207 -} 208 - 209 - 210 - 211 -# Stop monitoring of the clipboard 212 -proc twapi::stop_clipboard_monitor {clipid} { 213 - variable _clipboard_monitors 214 - 215 - if {![info exists _clipboard_monitors]} { 216 - return; # Should we raise an error instead? 217 - } 218 - 219 - set new_monitors {} 220 - foreach {id script} $_clipboard_monitors { 221 - if {$id ne $clipid} { 222 - lappend new_monitors $id $script 223 - } 224 - } 225 - 226 - set _clipboard_monitors $new_monitors 227 - if {[llength $_clipboard_monitors] == 0} { 228 - Twapi_ClipboardMonitorStop 229 - } 230 -}
Deleted winlibs/twapi/com.tcl.
1 -# 2 -# Copyright (c) 2006-2014 Ashok P. Nadkarni 3 -# All rights reserved. 4 -# 5 -# See the file LICENSE for license 6 - 7 -# TBD - tests comobj? works with derived classes of Automation 8 -# TBD - document and test -iterate -cleanup option 9 - 10 -# TBD - object identity comparison 11 -# - see http://blogs.msdn.com/ericlippert/archive/2005/04/26/412199.aspx 12 -# TBD - we seem to resolve UDT's every time a COM method is actually invoked. 13 -# Optimize by doing it when prototype is stored or only the first time it 14 -# is called. 15 -# TBD - optimize by caching UDT's within a type library when the library 16 -# is read. 17 - 18 -namespace eval twapi { 19 - # Maps TYPEKIND data values to symbols 20 - variable _typekind_map 21 - array set _typekind_map { 22 - 0 enum 23 - 1 record 24 - 2 module 25 - 3 interface 26 - 4 dispatch 27 - 5 coclass 28 - 6 alias 29 - 7 union 30 - } 31 - 32 - # Cache of Interface names - IID mappings 33 - variable _name_to_iid_cache 34 - array set _name_to_iid_cache { 35 - iunknown {{00000000-0000-0000-C000-000000000046}} 36 - idispatch {{00020400-0000-0000-C000-000000000046}} 37 - idispatchex {{A6EF9860-C720-11D0-9337-00A0C90DCAA9}} 38 - itypeinfo {{00020401-0000-0000-C000-000000000046}} 39 - itypecomp {{00020403-0000-0000-C000-000000000046}} 40 - ienumvariant {{00020404-0000-0000-C000-000000000046}} 41 - iprovideclassinfo {{B196B283-BAB4-101A-B69C-00AA00341D07}} 42 - 43 - ipersist {{0000010c-0000-0000-C000-000000000046}} 44 - ipersistfile {{0000010b-0000-0000-C000-000000000046}} 45 - 46 - iprovidetaskpage {{4086658a-cbbb-11cf-b604-00c04fd8d565}} 47 - itasktrigger {{148BD52B-A2AB-11CE-B11F-00AA00530503}} 48 - ischeduleworkitem {{a6b952f0-a4b1-11d0-997d-00aa006887ec}} 49 - itask {{148BD524-A2AB-11CE-B11F-00AA00530503}} 50 - ienumworkitems {{148BD528-A2AB-11CE-B11F-00AA00530503}} 51 - itaskscheduler {{148BD527-A2AB-11CE-B11F-00AA00530503}} 52 - imofcompiler {{6daf974e-2e37-11d2-aec9-00c04fb68820}} 53 - } 54 -} 55 - 56 -proc twapi::IUnknown_QueryInterface {ifc iid} { 57 - set iidname void 58 - catch {set iidname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]} 59 - return [Twapi_IUnknown_QueryInterface $ifc $iid $iidname] 60 -} 61 - 62 -proc twapi::CoGetObject {name bindopts iid} { 63 - set iidname void 64 - catch {set iidname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]} 65 - return [Twapi_CoGetObject $name $bindopts $iid $iidname] 66 -} 67 - 68 -proc twapi::progid_to_clsid {progid} { return [CLSIDFromProgID $progid] } 69 -proc twapi::clsid_to_progid {progid} { return [ProgIDFromCLSID $progid] } 70 - 71 -proc twapi::com_security_blanket {args} { 72 - # mutualauth.bool - docs for EOLE_AUTHENTICATION_CAPABILITIES. Learning 73 - # DCOM says it is only for CoInitializeSecurity. Either way, 74 - # that option is not applicable here 75 - parseargs args { 76 - {authenticationservice.arg default} 77 - serverprincipal.arg 78 - {authenticationlevel.arg default} 79 - {impersonationlevel.arg default} 80 - credentials.arg 81 - cloaking.arg 82 - } -maxleftover 0 -setvars 83 - 84 - set authenticationservice [_com_name_to_authsvc $authenticationservice] 85 - set authenticationlevel [_com_name_to_authlevel $authenticationlevel] 86 - set impersonationlevel [_com_name_to_impersonation $impersonationlevel] 87 - 88 - if {![info exists cloaking]} { 89 - set eoac 0x800; # EOAC_DEFAULT 90 - } else { 91 - set eoac [dict! {none 0 static 0x20 dynamic 0x40} $cloaking] 92 - } 93 - 94 - if {[info exists credentials]} { 95 - # Credentials specified. Empty list -> NULL, ie use thread token 96 - set creds_tag 1 97 - } else { 98 - # Credentials not to be changed 99 - set creds_tag 0 100 - set credentials {}; # Ignored 101 - } 102 - 103 - if {[info exists serverprincipal]} { 104 - if {$serverprincipal eq ""} { 105 - set serverprincipaltag 0; # Default based on com_initialize_security 106 - } else { 107 - set serverprincipaltag 2 108 - } 109 - } else { 110 - set serverprincipaltag 1; # Unchanged server principal 111 - set serverprincipal "" 112 - } 113 - 114 - return [list $authenticationservice 0 $serverprincipaltag $serverprincipal $authenticationlevel $impersonationlevel $creds_tag $credentials $eoac] 115 -} 116 - 117 -# TBD - document 118 -proc twapi::com_query_client_blanket {} { 119 - lassign [CoQueryClientBlanket] authn authz server authlevel implevel client capabilities 120 - if {$capabilities & 0x20} { 121 - # EOAC_STATIC_CLOAKING 122 - set cloaking static 123 - } elseif {$capabilities & 0x40} { 124 - set cloaking dynamic 125 - } else { 126 - set cloaking none 127 - } 128 - 129 - # Note there is no implevel set as CoQueryClientBlanket does 130 - # not return that information and implevel is a dummy value 131 - return [list \ 132 - -authenticationservice [_com_authsvc_to_name $authn] \ 133 - -authorizationservice [dict* {0 none 1 name 2 dce} $authz] \ 134 - -serverprincipal $server \ 135 - -authenticationlevel [_com_authlevel_to_name $authlevel] \ 136 - -clientprincipal $client \ 137 - -cloaking $cloaking \ 138 - ] 139 -} 140 - 141 -# TBD - document 142 -proc twapi::com_query_proxy_blanket {ifc} { 143 - lassign [CoQueryProxyBlanket [lindex $args 0]] authn authz server authlevel implevel client capabilities 144 - if {$capabilities & 0x20} { 145 - # EOAC_STATIC_CLOAKING 146 - set cloaking static 147 - } elseif {$capabilities & 0x40} { 148 - set cloaking dynamic 149 - } else { 150 - set cloaking none 151 - } 152 - 153 - return [list \ 154 - -authenticationservice [_com_authsvc_to_name $authn] \ 155 - -authorizationservice [dict* {0 none 1 name 2 dce} $authz] \ 156 - -serverprincipal $server \ 157 - -authenticationlevel [_com_authlevel_to_name $authlevel] \ 158 - -impersonationlevel [_com_impersonation_to_name $implevel] \ 159 - -clientprincipal $client \ 160 - -cloaking $cloaking \ 161 - ] 162 - 163 -} 164 - 165 -# TBD - document 166 -proc twapi::com_initialize_security {args} { 167 - # TBD - mutualauth? 168 - # TBD - securerefs? 169 - parseargs args { 170 - {authenticationlevel.arg default} 171 - {impersonationlevel.arg impersonate} 172 - {cloaking.sym none {none 0 static 0x20 dynamic 0x40}} 173 - secd.arg 174 - appid.arg 175 - authenticationservices.arg 176 - } -maxleftover 0 -setvars 177 - 178 - if {[info exists secd] && [info exists appid]} { 179 - badargs! "Only one of -secd and -appid can be specified." 180 - } 181 - 182 - set impersonationlevel [_com_name_to_impersonation $impersonationlevel] 183 - set authenticationlevel [_com_name_to_authlevel $authenticationlevel] 184 - 185 - set eoac $cloaking 186 - if {[info exists appid]} { 187 - incr eoac 8; # 8 -> EOAC_APPID 188 - set secarg $appid 189 - } else { 190 - if {[info exists secd]} { 191 - set secarg $secd 192 - } else { 193 - set secarg {} 194 - } 195 - } 196 - 197 - set authlist {} 198 - if {[info exists authenticationservices]} { 199 - foreach authsvc $authenticationservices { 200 - lappend authlist [list [_com_name_to_authsvc [lindex $authsvc 0]] 0 [lindex $authsvc 1]] 201 - } 202 - } 203 - 204 - CoInitializeSecurity $secarg "" "" $authenticationlevel $impersonationlevel $authlist $eoac "" 205 -} 206 - 207 -interp alias {} twapi::com_make_credentials {} twapi::make_logon_identity 208 - 209 -# TBD - document 210 -proc twapi::com_create_instance {clsid args} { 211 - array set opts [parseargs args { 212 - {model.arg any} 213 - download.bool 214 - {disablelog.bool false} 215 - enableaaa.bool 216 - {nocustommarshal.bool false 0x1000} 217 - {interface.arg IUnknown} 218 - {authenticationservice.arg none} 219 - {impersonationlevel.arg impersonate} 220 - {credentials.arg {}} 221 - {serverprincipal.arg {}} 222 - {authenticationlevel.arg default} 223 - {mutualauth.bool 0 0x1} 224 - securityblanket.arg 225 - system.arg 226 - raw 227 - } -maxleftover 0] 228 - 229 - set opts(authenticationservice) [_com_name_to_authsvc $opts(authenticationservice)] 230 - set opts(authenticationlevel) [_com_name_to_authlevel $opts(authenticationlevel)] 231 - set opts(impersonationlevel) [_com_name_to_impersonation $opts(impersonationlevel)] 232 - 233 - # CLSCTX_NO_CUSTOM_MARSHAL ? 234 - set flags $opts(nocustommarshal) 235 - 236 - set model 0 237 - if {[info exists opts(model)]} { 238 - foreach m $opts(model) { 239 - switch -exact -- $m { 240 - any {setbits model 23} 241 - inprocserver {setbits model 1} 242 - inprochandler {setbits model 2} 243 - localserver {setbits model 4} 244 - remoteserver {setbits model 16} 245 - } 246 - } 247 - } 248 - 249 - setbits flags $model 250 - 251 - if {[info exists opts(download)]} { 252 - if {$opts(download)} { 253 - setbits flags 0x2000; # CLSCTX_ENABLE_CODE_DOWNLOAD 254 - } else { 255 - setbits flags 0x400; # CLSCTX_NO_CODE_DOWNLOAD 256 - } 257 - } 258 - 259 - if {$opts(disablelog)} { 260 - setbits flags 0x4000; # CLSCTX_NO_FAILURE_LOG 261 - } 262 - 263 - if {[info exists opts(enableaaa)]} { 264 - if {$opts(enableaaa)} { 265 - setbits flags 0x10000; # CLSCTX_ENABLE_AAA 266 - } else { 267 - setbits flags 0x8000; # CLSCTX_DISABLE_AAA 268 - } 269 - } 270 - 271 - if {[info exists opts(system)]} { 272 - set coserverinfo [list 0 $opts(system) \ 273 - [list $opts(authenticationservice) \ 274 - 0 \ 275 - $opts(serverprincipal) \ 276 - $opts(authenticationlevel) \ 277 - $opts(impersonationlevel) \ 278 - $opts(credentials) \ 279 - $opts(mutualauth) \ 280 - ] \ 281 - 0] 282 - set activation_blanket \ 283 - [com_security_blanket \ 284 - -authenticationservice $opts(authenticationservice) \ 285 - -serverprincipal $opts(serverprincipal) \ 286 - -authenticationlevel $opts(authenticationlevel) \ 287 - -impersonationlevel $opts(impersonationlevel) \ 288 - -credentials $opts(credentials)] 289 - } else { 290 - set coserverinfo {} 291 - } 292 - 293 - # If remote, set the specified security blanket on the proxy. Note 294 - # that the blanket settings passed to CoCreateInstanceEx are used 295 - # only for activation and do NOT get passed down to method calls 296 - # If a remote component is activated with specific identity, we 297 - # assume method calls require the same security settings. 298 - 299 - if {([info exists activation_blanket] || [llength $opts(credentials)]) && 300 - ![info exists opts(securityblanket)]} { 301 - if {[info exists activation_blanket]} { 302 - set opts(securityblanket) $activation_blanket 303 - } else { 304 - set opts(securityblanket) [com_security_blanket -credentials $opts(credentials)] 305 - } 306 - } 307 - 308 - lassign [_resolve_iid $opts(interface)] iid iid_name 309 - 310 - # TBD - is all this OleRun still necessary or is there a check we can make 311 - # before going down that path ? 312 - # Microsoft Office (and maybe others) have some, uhhm, quirks. 313 - # If they are loaded as inproc, all calls to retrieve an interface other 314 - # than IUnknown fails. We have to get the IUnknown interface, 315 - # call OleRun and then retrieve the desired interface. 316 - # This does not happen if the localserver model was requested. 317 - # We could check for a specific error code but no guarantee that 318 - # the error is same in all versions so we catch and retry on all errors. 319 - # 3rd element of each sublist is status. Non-0 -> Failure code 320 - if {[catch {set ifcs [CoCreateInstanceEx $clsid NULL $flags $coserverinfo [list $iid]]}] || [lindex $ifcs 0 2] != 0} { 321 - # Try through IUnknown 322 - set ifcs [CoCreateInstanceEx $clsid NULL $flags $coserverinfo [list [_iid_iunknown]]] 323 - 324 - if {[lindex $ifcs 0 2] != 0} { 325 - win32_error [lindex $ifcs 0 2] 326 - } 327 - set iunk [lindex $ifcs 0 1] 328 - 329 - # Need to set security blanket if specified before invoking any method 330 - # else will get access denied 331 - if {[info exists opts(securityblanket)]} { 332 - trap { 333 - CoSetProxyBlanket $iunk {*}$opts(securityblanket) 334 - } onerror {} { 335 - IUnknown_Release $iunk 336 - rethrow 337 - } 338 - } 339 - 340 - trap { 341 - # Wait for it to run, then get desired interface from it 342 - twapi::OleRun $iunk 343 - set ifc [Twapi_IUnknown_QueryInterface $iunk $iid $iid_name] 344 - } finally { 345 - IUnknown_Release $iunk 346 - } 347 - } else { 348 - set ifc [lindex $ifcs 0 1] 349 - } 350 - 351 - # All interfaces are returned typed as IUnknown by the C level 352 - # even though they are actually the requested type. 353 - set ifc [cast_handle $ifc $iid_name] 354 - 355 - if {[info exists activation_blanket]} { 356 - # In order for servers to release objects properly, the IUnknown 357 - # interface must have the same security settings as were used in 358 - # the object creation 359 - _com_set_iunknown_proxy $ifc $activation_blanket 360 - } 361 - 362 - if {$opts(raw)} { 363 - if {[info exists opts(securityblanket)]} { 364 - trap { 365 - CoSetProxyBlanket $ifc {*}$opts(securityblanket) 366 - } onerror {} { 367 - IUnknown_Release $ifc 368 - rethrow 369 - } 370 - } 371 - return $ifc 372 - } else { 373 - set proxy [make_interface_proxy $ifc] 374 - if {[info exists opts(securityblanket)]} { 375 - trap { 376 - $proxy @SetSecurityBlanket $opts(securityblanket) 377 - } onerror {} { 378 - catch {$proxy Release} 379 - rethrow 380 - } 381 - } 382 - return $proxy 383 - } 384 -} 385 - 386 - 387 -proc twapi::comobj_idispatch {ifc {addref 0} {objclsid ""} {lcid 0}} { 388 - if {[pointer_null? $ifc]} { 389 - return ::twapi::comobj_null 390 - } 391 - 392 - if {[pointer? $ifc IDispatch]} { 393 - if {$addref} { IUnknown_AddRef $ifc } 394 - set proxyobj [IDispatchProxy new $ifc $objclsid] 395 - } elseif {[pointer? $ifc IDispatchEx]} { 396 - if {$addref} { IUnknown_AddRef $ifc } 397 - set proxyobj [IDispatchExProxy new $ifc $objclsid] 398 - } else { 399 - error "'$ifc' does not reference an IDispatch interface" 400 - } 401 - 402 - return [Automation new $proxyobj $lcid] 403 -} 404 - 405 -# 406 -# Create an object command for a COM object from a name 407 -proc twapi::comobj_object {path args} { 408 - array set opts [parseargs args { 409 - progid.arg 410 - {interface.arg IDispatch {IDispatch IDispatchEx}} 411 - {lcid.int 0} 412 - } -maxleftover 0] 413 - 414 - set clsid "" 415 - if {[info exists opts(progid)]} { 416 - # TBD - document once we have a test case for this 417 - # Specify which app to use to open the file. 418 - # See "Mapping Visual Basic to Automation" in SDK help 419 - set clsid [_convert_to_clsid $opts(progid)] 420 - set ipersistfile [com_create_instance $clsid -interface IPersistFile] 421 - trap { 422 - IPersistFile_Load $ipersistfile $path 0 423 - set idisp [Twapi_IUnknown_QueryInterface $ipersistfile [_iid_idispatch] IDispatch] 424 - } finally { 425 - IUnknown_Release $ipersistfile 426 - } 427 - } else { 428 - # TBD - can we get the CLSID for this case 429 - set idisp [::twapi::Twapi_CoGetObject $path {} [name_to_iid $opts(interface)] $opts(interface)] 430 - } 431 - 432 - return [comobj_idispatch $idisp 0 $clsid $opts(lcid)] 433 -} 434 - 435 -# 436 -# Create a object command for a COM object IDispatch interface 437 -# comid is either a CLSID or a PROGID 438 -proc twapi::comobj {comid args} { 439 - array set opts [parseargs args { 440 - {interface.arg IDispatch {IDispatch IDispatchEx}} 441 - active 442 - {lcid.int 0} 443 - } -ignoreunknown] 444 - set clsid [_convert_to_clsid $comid] 445 - if {$opts(active)} { 446 - set iunk [GetActiveObject $clsid] 447 - twapi::trap { 448 - # TBD - do we need to deal with security blanket here? How do 449 - # know what blanket is to be used on an already active object? 450 - # Get the IDispatch interface 451 - set idisp [IUnknown_QueryInterface $iunk {{00020400-0000-0000-C000-000000000046}}] 452 - return [comobj_idispatch $idisp 0 $clsid $opts(lcid)] 453 - } finally { 454 - IUnknown_Release $iunk 455 - } 456 - } else { 457 - set proxy [com_create_instance $clsid -interface $opts(interface) {*}$args] 458 - $proxy @SetCLSID $clsid 459 - return [Automation new $proxy $opts(lcid)] 460 - } 461 -} 462 - 463 -proc twapi::comobj_destroy args { 464 - foreach arg $args { 465 - catch {$arg -destroy} 466 - } 467 -} 468 - 469 -# Return an interface to a typelib 470 -# TBD - document 471 -proc twapi::ITypeLibProxy_from_path {path args} { 472 - array set opts [parseargs args { 473 - {registration.arg none {none register default}} 474 - } -maxleftover 0] 475 - 476 - return [make_interface_proxy [LoadTypeLibEx $path [kl_get {default 0 register 1 none 2} $opts(registration) $opts(registration)]]] 477 -} 478 - 479 -# 480 -# Return an interface to a typelib from the registry 481 -# TBD - document 482 -proc twapi::ITypeLibProxy_from_guid {uuid major minor args} { 483 - array set opts [parseargs args { 484 - lcid.int 485 - } -maxleftover 0 -nulldefault] 486 - 487 - return [make_interface_proxy [LoadRegTypeLib $uuid $major $minor $opts(lcid)]] 488 -} 489 - 490 -# 491 -# Unregister a typelib 492 -proc twapi::unregister_typelib {uuid major minor args} { 493 - array set opts [parseargs args { 494 - lcid.int 495 - } -maxleftover 0 -nulldefault] 496 - 497 - UnRegisterTypeLib $uuid $major $minor $opts(lcid) 1 498 -} 499 - 500 -# 501 -# Returns the path to the typelib based on a guid 502 -proc twapi::get_typelib_path_from_guid {guid major minor args} { 503 - array set opts [parseargs args { 504 - lcid.int 505 - } -maxleftover 0 -nulldefault] 506 - 507 - 508 - set path [variant_value [QueryPathOfRegTypeLib $guid $major $minor $opts(lcid)] 0 0 $opts(lcid)] 509 - # At least some versions have a bug in that there is an extra \0 510 - # at the end. 511 - if {[string equal [string index $path end] \0]} { 512 - set path [string range $path 0 end-1] 513 - } 514 - return $path 515 -} 516 - 517 -# 518 -# Map interface name to IID 519 -proc twapi::name_to_iid {iname} { 520 - set iname [string tolower $iname] 521 - 522 - if {[info exists ::twapi::_name_to_iid_cache($iname)]} { 523 - return $::twapi::_name_to_iid_cache($iname) 524 - } 525 - 526 - # Look up the registry 527 - set iids {} 528 - foreach iid [registry keys HKEY_CLASSES_ROOT\\Interface] { 529 - if {![catch { 530 - set val [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""] 531 - }]} { 532 - if {[string equal -nocase $iname $val]} { 533 - lappend iids $iid 534 - } 535 - } 536 - } 537 - 538 - if {[llength $iids] == 1} { 539 - return [set ::twapi::_name_to_iid_cache($iname) [lindex $iids 0]] 540 - } elseif {[llength $iids]} { 541 - error "Multiple interfaces found matching name $iname: [join $iids ,]" 542 - } else { 543 - return [set ::twapi::_name_to_iid_cache($iname) ""] 544 - } 545 -} 546 - 547 - 548 -# 549 -# Map interface IID to name 550 -proc twapi::iid_to_name {iid} { 551 - set iname "" 552 - catch {set iname [registry get HKEY_CLASSES_ROOT\\Interface\\$iid ""]} 553 - return $iname 554 -} 555 - 556 -# 557 -# Convert a variant time to a time list 558 -proc twapi::variant_time_to_timelist {double} { 559 - return [VariantTimeToSystemTime $double] 560 -} 561 - 562 -# 563 -# Convert a time list time to a variant time 564 -proc twapi::timelist_to_variant_time {timelist} { 565 - return [SystemTimeToVariantTime $timelist] 566 -} 567 - 568 - 569 -proc twapi::typelib_print {path args} { 570 - array set opts [parseargs args { 571 - type.arg 572 - name.arg 573 - output.arg 574 - } -maxleftover 0 -nulldefault] 575 - 576 - 577 - if {$opts(output) ne ""} { 578 - if {[file exists $opts(output)]} { 579 - error "File $opts(output) already exists." 580 - } 581 - set outfd [open $opts(output) a] 582 - } else { 583 - set outfd stdout 584 - } 585 - 586 - trap { 587 - set tl [ITypeLibProxy_from_path $path -registration none] 588 - puts $outfd [$tl @Text -type $opts(type) -name $opts(name)] 589 - } finally { 590 - if {[info exists tl]} { 591 - $tl Release 592 - } 593 - if {$outfd ne "stdout"} { 594 - close $outfd 595 - } 596 - } 597 - 598 - return 599 -} 600 - 601 -proc twapi::generate_code_from_typelib {path args} { 602 - array set opts [parseargs args { 603 - output.arg 604 - } -ignoreunknown] 605 - 606 - if {[info exists opts(output)]} { 607 - if {$opts(output) ne "stdout"} { 608 - if {[file exists $opts(output)]} { 609 - error "File $opts(output) already exists." 610 - } 611 - set outfd [open $opts(output) a] 612 - } else { 613 - set outfd stdout 614 - } 615 - } 616 - 617 - trap { 618 - set tl [ITypeLibProxy_from_path $path -registration none] 619 - set code [$tl @GenerateCode {*}$args] 620 - if {[info exists outfd]} { 621 - puts $outfd "package require twapi_com" 622 - puts $outfd $code 623 - return 624 - } else { 625 - return $code 626 - } 627 - } finally { 628 - if {[info exists tl]} { 629 - $tl Release 630 - } 631 - if {[info exists outfd] && $outfd ne "stdout"} { 632 - close $outfd 633 - } 634 - } 635 -} 636 - 637 - 638 - 639 - 640 -proc twapi::_interface_text {ti} { 641 - # ti must be TypeInfo for an interface or module (or enum?) - TBD 642 - set desc "" 643 - array set attrs [$ti @GetTypeAttr -all] 644 - set desc "Functions:\n" 645 - for {set j 0} {$j < $attrs(-fncount)} {incr j} { 646 - array set funcdata [$ti @GetFuncDesc $j -all] 647 - if {$funcdata(-funckind) eq "dispatch"} { 648 - set funckind "(dispid $funcdata(-memid))" 649 - } else { 650 - set funckind "(vtable $funcdata(-vtbloffset))" 651 - } 652 - append desc "\t$funckind [::twapi::_resolve_com_type_text $ti $funcdata(-datatype)] $funcdata(-name) $funcdata(-invkind) [::twapi::_resolve_com_params_text $ti $funcdata(-params) $funcdata(-paramnames)]\n" 653 - } 654 - append desc "Variables:\n" 655 - for {set j 0} {$j < $attrs(-varcount)} {incr j} { 656 - array set vardata [$ti @GetVarDesc $j -all] 657 - set vardesc "($vardata(-memid)) $vardata(-varkind) [::twapi::_flatten_com_type [::twapi::_resolve_com_type_text $ti $vardata(-datatype)]] $vardata(-name)" 658 - if {$attrs(-typekind) eq "enum" || $vardata(-varkind) eq "const"} { 659 - append vardesc " = $vardata(-value)" 660 - } else { 661 - append vardesc " (offset $vardata(-value))" 662 - } 663 - append desc "\t$vardesc\n" 664 - } 665 - return $desc 666 -} 667 - 668 -# 669 -# Print methods in an interface, including inherited names 670 -proc twapi::dispatch_print {di args} { 671 - array set opts [parseargs args { 672 - output.arg 673 - } -maxleftover 0 -nulldefault] 674 - 675 - if {$opts(output) ne ""} { 676 - if {[file exists $opts(output)]} { 677 - error "File $opts(output) already exists." 678 - } 679 - set outfd [open $opts(output) a] 680 - } else { 681 - set outfd stdout 682 - } 683 - 684 - trap { 685 - set ti [$di @GetTypeInfo] 686 - twapi::_dispatch_print_helper $ti $outfd 687 - } finally { 688 - if {[info exists ti]} { 689 - $ti Release 690 - } 691 - if {$outfd ne "stdout"} { 692 - close $outfd 693 - } 694 - } 695 - 696 - return 697 -} 698 - 699 -proc twapi::_dispatch_print_helper {ti outfd {names_already_done ""}} { 700 - set name [$ti @GetName] 701 - if {$name in $names_already_done} { 702 - # Already printed this 703 - return $names_already_done 704 - } 705 - lappend names_already_done $name 706 - 707 - # Check for dual interfaces - we want to print both vtable and disp versions 708 - set tilist [list $ti] 709 - if {![catch {set ti2 [$ti @GetRefTypeInfoFromIndex $ti -1]}]} { 710 - lappend tilist $ti2 711 - } 712 - 713 - trap { 714 - foreach tifc $tilist { 715 - puts $outfd $name 716 - puts $outfd [_interface_text $tifc] 717 - } 718 - } finally { 719 - if {[info exists ti2]} { 720 - $ti2 Release 721 - } 722 - } 723 - 724 - # Now get any referenced typeinfos and print them 725 - array set tiattrs [$ti GetTypeAttr] 726 - for {set j 0} {$j < $tiattrs(cImplTypes)} {incr j} { 727 - set ti2 [$ti @GetRefTypeInfoFromIndex $j] 728 - trap { 729 - set names_already_done [_dispatch_print_helper $ti2 $outfd $names_already_done] 730 - } finally { 731 - $ti2 Release 732 - } 733 - } 734 - 735 - return $names_already_done 736 -} 737 - 738 - 739 - 740 -# 741 -# Resolves references to parameter definition 742 -proc twapi::_resolve_com_params_text {ti params paramnames} { 743 - set result [list ] 744 - foreach param $params paramname $paramnames { 745 - set paramdesc [_flatten_com_type [_resolve_com_type_text $ti [lindex $param 0]]] 746 - if {[llength $param] > 1 && [llength [lindex $param 1]] > 0} { 747 - set paramdesc "\[[lindex $param 1]\] $paramdesc" 748 - } 749 - if {[llength $param] > 2} { 750 - append paramdesc " [lrange $param 2 end]" 751 - } 752 - append paramdesc " $paramname" 753 - lappend result $paramdesc 754 - } 755 - return "([join $result {, }])" 756 -} 757 - 758 -# Flattens the output of _resolve_com_type_text 759 -proc twapi::_flatten_com_type {com_type_desc} { 760 - if {[llength $com_type_desc] < 2} { 761 - return $com_type_desc 762 - } 763 - 764 - if {[lindex $com_type_desc 0] eq "ptr"} { 765 - return "[_flatten_com_type [lindex $com_type_desc 1]]*" 766 - } else { 767 - return "([lindex $com_type_desc 0] [_flatten_com_type [lindex $com_type_desc 1]])" 768 - } 769 -} 770 - 771 -# 772 -# Resolves typedefs 773 -proc twapi::_resolve_com_type_text {ti typedesc} { 774 - 775 - switch -exact -- [lindex $typedesc 0] { 776 - 26 - 777 - ptr { 778 - # Recurse to resolve any inner types 779 - set typedesc [list ptr [_resolve_com_type_text $ti [lindex $typedesc 1]]] 780 - } 781 - 29 - 782 - userdefined { 783 - set hreftype [lindex $typedesc 1] 784 - set ti2 [$ti @GetRefTypeInfo $hreftype] 785 - set typedesc "[$ti2 @GetName]" 786 - $ti2 Release 787 - } 788 - default { 789 - set typedesc [_vttype_to_string $typedesc] 790 - } 791 - } 792 - 793 - return $typedesc 794 -} 795 - 796 - 797 -# 798 -# Given a COM type descriptor, resolved all user defined types (UDT) in it 799 -# The descriptor must be in raw form as returned by the C code 800 -proc twapi::_resolve_comtype {ti typedesc} { 801 - 802 - if {[lindex $typedesc 0] == 26} { 803 - # VT_PTR - {26 INNER_TYPEDESC} 804 - # If pointing to a UDT, convert to appropriate base type if possible 805 - set inner [_resolve_comtype $ti [lindex $typedesc 1]] 806 - if {[lindex $inner 0] == 29} { 807 - # When the referenced type is a UDT (29) which is actually 808 - # a dispatch or other interface, replace the 809 - # "pointer to UDT" with VT_DISPATCH/VT_INTERFACE 810 - switch -exact -- [lindex $inner 1] { 811 - dispatch {set typedesc [list 9]} 812 - interface {set typedesc [list 13]} 813 - default { 814 - # TBD - need to decode all the other types (record etc.) 815 - set typedesc [list 26 $inner] 816 - } 817 - } 818 - } else { 819 - set typedesc [list 26 $inner] 820 - } 821 - } elseif {[lindex $typedesc 0] == 29} { 822 - # VT_USERDEFINED - {29 HREFTYPE} 823 - set ti2 [$ti @GetRefTypeInfo [lindex $typedesc 1]] 824 - array set tattr [$ti2 @GetTypeAttr -guid -typekind] 825 - if {$tattr(-typekind) eq "enum"} { 826 - set typedesc [list 3]; # 3 -> i4 827 - } else { 828 - if {$tattr(-typekind) eq "alias"} { 829 - set typedesc [_resolve_comtype $ti2 [kl_get [$ti2 GetTypeAttr] tdescAlias]] 830 - } else { 831 - set typedesc [list 29 $tattr(-typekind) $tattr(-guid)] 832 - } 833 - } 834 - $ti2 Release 835 - } 836 - 837 - return $typedesc 838 -} 839 - 840 -proc twapi::_resolve_params_for_prototype {ti paramdescs} { 841 - set params {} 842 - foreach paramdesc $paramdescs { 843 - lappend params \ 844 - [lreplace $paramdesc 0 0 [::twapi::_resolve_comtype $ti [lindex $paramdesc 0]]] 845 - } 846 - return $params 847 -} 848 - 849 -proc twapi::_variant_values_from_safearray {sa ndims {raw false} {addref false} {lcid 0}} { 850 - set result {} 851 - if {[incr ndims -1] > 0} { 852 - foreach elem $sa { 853 - lappend result [_variant_values_from_safearray $elem $ndims $raw $addref $lcid] 854 - } 855 - } else { 856 - foreach elem $sa { 857 - lappend result [twapi::variant_value $elem $raw $addref $lcid] 858 - } 859 - } 860 - return $result 861 -} 862 - 863 -proc twapi::outvar {varname} { return [Twapi_InternalCast outvar $varname] } 864 - 865 -# TBD - document 866 -# Returns a string value from a formatted variant value pair {VT_xxx value} 867 -# $addref controls whether we do an AddRef when the value is a pointer to 868 -# an interface. $raw controls whether interface pointers are returned 869 -# as raw interface handles or objects. 870 -proc twapi::variant_value {variant raw addref lcid} { 871 - # TBD - format appropriately depending on variant type for dates and 872 - # currency 873 - if {[llength $variant] == 0} { 874 - return "" 875 - } 876 - set vt [lindex $variant 0] 877 - 878 - if {$vt & 0x2000} { 879 - # VT_ARRAY - second element is {dimensions value} 880 - if {[llength $variant] < 2} { 881 - return [list ] 882 - } 883 - lassign [lindex $variant 1] dimensions values 884 - set vt [expr {$vt & ~ 0x2000}] 885 - if {$vt == 12} { 886 - # Array of variants. Recursively convert values 887 - return [_variant_values_from_safearray \ 888 - $values \ 889 - [expr {[llength $dimensions] / 2}] \ 890 - $raw $addref $lcid] 891 - } else { 892 - return $values 893 - } 894 - } else { 895 - if {$vt == 9} { 896 - set idisp [lindex $variant 1]; # May be NULL! 897 - if {$addref && ! [pointer_null? $idisp]} { 898 - IUnknown_AddRef $idisp 899 - } 900 - if {$raw} { 901 - return $idisp 902 - } else { 903 - # Note comobj_idispatch takes care of NULL 904 - return [comobj_idispatch $idisp 0 "" $lcid] 905 - } 906 - } elseif {$vt == 13} { 907 - set iunk [lindex $variant 1]; # May be NULL! 908 - if {$addref && ! [pointer_null? $iunk]} { 909 - IUnknown_AddRef $iunk 910 - } 911 - if {$raw} { 912 - return $iunk 913 - } else { 914 - return [make_interface_proxy $iunk] 915 - } 916 - } 917 - } 918 - return [lindex $variant 1] 919 -} 920 - 921 -proc twapi::variant_type {variant} { 922 - return [lindex $variant 0] 923 -} 924 - 925 -proc twapi::vt_null {} { 926 - return [tclcast null ""] 927 -} 928 - 929 -proc twapi::vt_empty {} { 930 - return [tclcast empty ""] 931 -} 932 - 933 -# 934 -# General dispatcher for callbacks from event sinks. Invokes the actual 935 -# registered script after mapping dispid's 936 -proc twapi::_eventsink_callback {comobj script callee args} { 937 - # Check if the comobj is still active 938 - if {[llength [info commands $comobj]] == 0} { 939 - if {$::twapi::log_config(twapi_com)} { 940 - debuglog "COM event received for inactive object" 941 - } 942 - return; # Object has gone away, ignore 943 - } 944 - 945 - set retcode [catch { 946 - # We are invoked with cooked values so no need to call variant_value 947 - uplevel #0 $script [list $callee] $args 948 - } result] 949 - 950 - if {$::twapi::log_config(twapi_com) && $retcode} { 951 - debuglog "Event sink callback error ($retcode): $result\n$::errorInfo" 952 - } 953 - 954 - # $retcode is returned as HRESULT by the Invoke 955 - return -code $retcode $result 956 -} 957 - 958 -# 959 -# Return clsid from a string. If $clsid is a valid CLSID - returns as is 960 -# else tries to convert it from progid. An error is generated if neither 961 -# works 962 -proc twapi::_convert_to_clsid {comid} { 963 - if {! [Twapi_IsValidGUID $comid]} { 964 - return [progid_to_clsid $comid] 965 - } 966 - return $comid 967 -} 968 - 969 -# 970 -# Format a prototype definition for human consumption 971 -# Proto is in the form {DISPID LCID INVOKEFLAGS RETTYPE PARAMTYPES PARAMNAMES} 972 -proc twapi::_format_prototype {name proto} { 973 - set dispid_lcid [lindex $proto 0]/[lindex $proto 1] 974 - set ret_type [_vttype_to_string [lindex $proto 3]] 975 - set invkind [_invkind_to_string [lindex $proto 2]] 976 - # Distinguish between no parameters and parameters not known 977 - set paramstr "" 978 - if {[llength $proto] > 4} { 979 - set params {} 980 - foreach param [lindex $proto 4] paramname [lindex $proto 5] { 981 - if {[string length $paramname]} { 982 - set paramname " $paramname" 983 - } 984 - lassign $param type paramdesc 985 - set type [_vttype_to_string $type] 986 - set parammods [_paramflags_to_tokens [lindex $paramdesc 0]] 987 - if {[llength [lindex $paramdesc 1]]} { 988 - # Default specified 989 - lappend parammods "default:[lindex [lindex $paramdesc 1] 1]" 990 - } 991 - lappend params "\[$parammods\] $type$paramname" 992 - } 993 - set paramstr " ([join $params {, }])" 994 - } 995 - return "$dispid_lcid $invkind $ret_type ${name}${paramstr}" 996 -} 997 - 998 -# Convert parameter modifiers to string tokens. 999 -# modifiers is list of integer flags or tokens. 1000 -proc twapi::_paramflags_to_tokens {modifiers} { 1001 - array set tokens {} 1002 - foreach mod $modifiers { 1003 - if {! [string is integer -strict $mod]} { 1004 - # mod is a token itself 1005 - set tokens($mod) "" 1006 - } else { 1007 - foreach tok [_make_symbolic_bitmask $mod { 1008 - in 1 1009 - out 2 1010 - lcid 4 1011 - retval 8 1012 - optional 16 1013 - hasdefault 32 1014 - hascustom 64 1015 - }] { 1016 - set tokens($tok) "" 1017 - } 1018 - } 1019 - } 1020 - 1021 - # For cosmetic reasons, in/out should be first and remaining sorted 1022 - # Also (in,out) -> inout 1023 - if {[info exists tokens(in)]} { 1024 - if {[info exists tokens(out)]} { 1025 - set inout [list inout] 1026 - unset tokens(in) 1027 - unset tokens(out) 1028 - } else { 1029 - set inout [list in] 1030 - unset tokens(in) 1031 - } 1032 - } else { 1033 - if {[info exists tokens(out)]} { 1034 - set inout [list out] 1035 - unset tokens(out) 1036 - } 1037 - } 1038 - 1039 - if {[info exists inout]} { 1040 - return [linsert [lsort [array names tokens]] 0 $inout] 1041 - } else { 1042 - return [lsort [array names tokens]] 1043 - } 1044 -} 1045 - 1046 -# 1047 -# Map method invocation code to string 1048 -# Return code itself if no match 1049 -proc twapi::_invkind_to_string {code} { 1050 - return [kl_get { 1051 - 1 func 1052 - 2 propget 1053 - 4 propput 1054 - 8 propputref 1055 - } $code $code] 1056 -} 1057 - 1058 -# 1059 -# Map string method invocation symbol to code 1060 -# Error if no match and not an integer 1061 -proc twapi::_string_to_invkind {s} { 1062 - if {[string is integer $s]} { return $s } 1063 - return [kl_get { 1064 - func 1 1065 - propget 2 1066 - propput 4 1067 - propputref 8 1068 - } $s] 1069 -} 1070 - 1071 - 1072 -# 1073 -# Convert a VT typedef to a string 1074 -# vttype may be nested 1075 -proc twapi::_vttype_to_string {vttype} { 1076 - set vts [_vtcode_to_string [lindex $vttype 0]] 1077 - if {[llength $vttype] < 2} { 1078 - return $vts 1079 - } 1080 - 1081 - return [list $vts [_vttype_to_string [lindex $vttype 1]]] 1082 -} 1083 - 1084 -# 1085 -# Convert VT codes to strings 1086 -proc twapi::_vtcode_to_string {vt} { 1087 - return [kl_get { 1088 - 2 i2 1089 - 3 i4 1090 - 4 r4 1091 - 5 r8 1092 - 6 cy 1093 - 7 date 1094 - 8 bstr 1095 - 9 idispatch 1096 - 10 error 1097 - 11 bool 1098 - 12 variant 1099 - 13 iunknown 1100 - 14 decimal 1101 - 16 i1 1102 - 17 ui1 1103 - 18 ui2 1104 - 19 ui4 1105 - 20 i8 1106 - 21 ui8 1107 - 22 int 1108 - 23 uint 1109 - 24 void 1110 - 25 hresult 1111 - 26 ptr 1112 - 27 safearray 1113 - 28 carray 1114 - 29 userdefined 1115 - 30 lpstr 1116 - 31 lpwstr 1117 - 36 record 1118 - } $vt $vt] 1119 -} 1120 - 1121 -proc twapi::_string_to_base_vt {tok} { 1122 - # Only maps base VT tokens to numeric value 1123 - # TBD - record and userdefined? 1124 - return [dict get { 1125 - i2 2 1126 - i4 3 1127 - r4 4 1128 - r8 5 1129 - cy 6 1130 - date 7 1131 - bstr 8 1132 - idispatch 9 1133 - error 10 1134 - bool 11 1135 - iunknown 13 1136 - decimal 14 1137 - i1 16 1138 - ui1 17 1139 - ui2 18 1140 - ui4 19 1141 - i8 20 1142 - ui8 21 1143 - int 22 1144 - uint 23 1145 - hresult 25 1146 - userdefined 29 1147 - record 36 1148 - } [string tolower $tok]] 1149 - 1150 -} 1151 - 1152 -# 1153 -# Get ADSI provider service 1154 -proc twapi::_adsi {{prov WinNT} {path {//.}}} { 1155 - return [comobj_object "${prov}:$path"] 1156 -} 1157 - 1158 -# Get cached IDispatch and IUNknown IID's 1159 -proc twapi::_iid_iunknown {} { 1160 - return $::twapi::_name_to_iid_cache(iunknown) 1161 -} 1162 -proc twapi::_iid_idispatch {} { 1163 - return $::twapi::_name_to_iid_cache(idispatch) 1164 -} 1165 - 1166 -# 1167 -# Return IID and name given a IID or name 1168 -proc twapi::_resolve_iid {name_or_iid} { 1169 - 1170 - # IID -> name mapping is more efficient so first assume it is 1171 - # an IID else we will unnecessarily trundle through the whole 1172 - # registry area looking for an IID when we already have it 1173 - # Assume it is a name 1174 - set other [iid_to_name $name_or_iid] 1175 - if {$other ne ""} { 1176 - # It was indeed the IID. Return the pair 1177 - return [list $name_or_iid $other] 1178 - } 1179 - 1180 - # Else resolve as a name 1181 - set other [name_to_iid $name_or_iid] 1182 - if {$other ne ""} { 1183 - # Yep 1184 - return [list $other $name_or_iid] 1185 - } 1186 - 1187 - win32_error 0x80004002 "Could not find IID $name_or_iid" 1188 -} 1189 - 1190 - 1191 -namespace eval twapi { 1192 - # Enable use of TclOO for new Tcl versions. To override setting 1193 - # applications should define and set before sourcing this file. 1194 - variable use_tcloo_for_com 1195 - if {![info exists use_tcloo_for_com]} { 1196 - set use_tcloo_for_com [package vsatisfies [package require Tcl] 8.6b2] 1197 - } 1198 - if {$use_tcloo_for_com} { 1199 - interp alias {} ::twapi::class {} ::oo::class 1200 - proc ::oo::define::twapi_exportall {} { 1201 - uplevel 1 export [info class methods [lindex [info level -1] 1] -private] 1202 - } 1203 - proc comobj? {cobj} { 1204 - # TBD - would it be faster to keep explicit track through 1205 - # a dictionary ? 1206 - set cobj [uplevel 1 [list namespace which -command $cobj]] 1207 - if {[info object isa object $cobj] && 1208 - [info object isa typeof $cobj ::twapi::Automation]} { 1209 - return 1 1210 - } else { 1211 - return 0 1212 - } 1213 - } 1214 - proc comobj_instances {} { 1215 - set comobj_classes [list ::twapi::Automation] 1216 - set objs {} 1217 - while {[llength $comobj_classes]} { 1218 - set comobj_classes [lassign $comobj_classes class] 1219 - lappend objs {*}[info class instances $class] 1220 - lappend comobj_classes {*}[info class subclasses $class] 1221 - } 1222 - # Get rid of dups which may occur if subclasses use 1223 - # multiple (diamond type) inheritance 1224 - return [lsort -unique $objs] 1225 - } 1226 - } else { 1227 - package require metoo 1228 - interp alias {} ::twapi::class {} ::metoo::class 1229 - namespace eval ::metoo::define { 1230 - proc twapi_exportall {args} { 1231 - # args is dummy to match metoo's class definition signature 1232 - # Nothing to do, all methods are metoo are public 1233 - } 1234 - } 1235 - proc comobj? {cobj} { 1236 - set cobj [uplevel 1 [list namespace which -command $cobj]] 1237 - return [metoo::introspect object isa $cobj ::twapi::Automation] 1238 - } 1239 - proc comobj_instances {} { 1240 - return [metoo::introspect object list ::twapi::Automation] 1241 - } 1242 - } 1243 - 1244 - # The prototype cache is indexed a composite key consisting of 1245 - # - the GUID of the interface, 1246 - # - the name of the function 1247 - # - the LCID 1248 - # - the invocation kind (as an integer) 1249 - # Each value contains the full prototype in a form 1250 - # that can be passed to IDispatch_Invoke. This is a list with the 1251 - # elements {DISPID LCID INVOKEFLAGS RETTYPE PARAMTYPES PARAMNAMES} 1252 - # Here PARAMTYPES is a list each element of which describes a 1253 - # parameter in the following format: 1254 - # {TYPE {FLAGS DEFAULT} NAMEDARGVALUE} where DEFAULT is optional 1255 - # and NAMEDARGVALUE only appears (optionally) when the prototype is 1256 - # passed to Invoke, not in the cached prototype itself. 1257 - # PARAMNAMES is list of parameter names in order and is 1258 - # only present if PARAMTYPES is also present. 1259 - 1260 - variable _dispatch_prototype_cache 1261 - array set _dispatch_prototype_cache {} 1262 -} 1263 - 1264 - 1265 -interp alias {} twapi::_dispatch_prototype_get {} twapi::dispatch_prototype_get 1266 -proc twapi::dispatch_prototype_get {guid name lcid invkind vproto} { 1267 - variable _dispatch_prototype_cache 1268 - set invkind [::twapi::_string_to_invkind $invkind] 1269 - if {[info exists _dispatch_prototype_cache($guid,$name,$lcid,$invkind)]} { 1270 - # Note this may be null if that name does not exist in the interface 1271 - upvar 1 $vproto proto 1272 - set proto $_dispatch_prototype_cache($guid,$name,$lcid,$invkind) 1273 - return 1 1274 - } 1275 - return 0 1276 -} 1277 - 1278 -# Update a prototype in cache. Note lcid and invkind cannot be 1279 -# picked up from prototype since it might be empty. 1280 -interp alias {} twapi::_dispatch_prototype_set {} twapi::dispatch_prototype_set 1281 -proc twapi::dispatch_prototype_set {guid name lcid invkind proto} { 1282 - # If the prototype does not contain the 5th element (params) 1283 - # it is a constructed prototype and we do NOT cache it as the 1284 - # disp id can change. Note empty prototypes are cached so 1285 - # we don't keep looking up something that does not exist 1286 - # Bug 130 1287 - 1288 - if {[llength $proto] == 4} { 1289 - return 1290 - } 1291 - 1292 - variable _dispatch_prototype_cache 1293 - set invkind [_string_to_invkind $invkind] 1294 - set _dispatch_prototype_cache($guid,$name,$lcid,$invkind) $proto 1295 - return 1296 -} 1297 - 1298 -# Explicitly set prototypes for a guid 1299 -# protolist is a list of alternating name and prototype pairs. 1300 -# Each prototype must contain the LCID and invkind fields 1301 -proc twapi::_dispatch_prototype_load {guid protolist} { 1302 - foreach {name proto} $protolist { 1303 - dispatch_prototype_set $guid $name [lindex $proto 1] [lindex $proto 2] $proto 1304 - } 1305 -} 1306 - 1307 -proc twapi::_parse_dispatch_paramdef {paramdef} { 1308 - set errormsg "Invalid parameter or return type declaration '$paramdef'" 1309 - 1310 - set paramregex {^(\[[^\]]*\])?\s*(\w+)\s*(\[\s*\])?\s*([*]?)\s*(\w+)?$} 1311 - if {![regexp $paramregex [string trim $paramdef] def attrs paramtype safearray ptr paramname]} { 1312 - error $errormsg 1313 - } 1314 - 1315 - if {[string length $paramname]} { 1316 - lappend paramnames $paramname 1317 - } 1318 - # attrs can be in, out, opt separated by spaces 1319 - set paramflags 0 1320 - foreach attr [string range $attrs 1 end-1] { 1321 - switch -exact -- $attr { 1322 - in {set paramflags [expr {$paramflags | 1}]} 1323 - out {set paramflags [expr {$paramflags | 2}]} 1324 - inout {set paramflags [expr {$paramflags | 3}]} 1325 - opt - 1326 - optional {set paramflags [expr {$paramflags | 16}]} 1327 - default {error "Unknown parameter attribute $attr"} 1328 - } 1329 - } 1330 - if {($paramflags & 3) == 0} { 1331 - set paramflags [expr {$paramflags | 1}]; # in param if unspecified 1332 - } 1333 - # Resolve parameter type. It can be 1334 - # - a safearray of base types or "variant"s (not pointers) 1335 - # - a pointer to a base type 1336 - # - a pointer to a safearray 1337 - # - a base type or "variant" 1338 - switch -exact -- $paramtype { 1339 - variant { set paramtype 12 } 1340 - void { set paramtype 24 } 1341 - default { set paramtype [_string_to_base_vt $paramtype] } 1342 - } 1343 - if {[string length $safearray]} { 1344 - if {$paramtype == 24} { 1345 - # Safearray of type void is an invalid type decl 1346 - error $errormsg 1347 - } 1348 - set paramtype [list 27 $paramtype] 1349 - } 1350 - if {[string length $ptr]} { 1351 - if {$paramtype == 24} { 1352 - # Pointer to type void is an invalid type 1353 - error $errormsg 1354 - } 1355 - set paramtype [list 26 $paramtype] 1356 - } 1357 - 1358 - return [list $paramflags $paramtype $paramname] 1359 -} 1360 - 1361 -proc twapi::define_dispatch_prototypes {guid protos args} { 1362 - array set opts [parseargs args { 1363 - {lcid.int 0} 1364 - } -maxleftover 0] 1365 - 1366 - set guid [canonicalize_guid $guid] 1367 - 1368 - set defregx {^\s*(\w+)\s+(\d+)\s+(\w[^\(]*)\(([^\)]*)\)(.*)$} 1369 - set parsed_protos {} 1370 - # Loop picking out one prototype in each interation 1371 - while {[regexp $defregx $protos -> membertype memid rettype paramstring protos]} { 1372 - set params {} 1373 - set paramnames {} 1374 - foreach paramdef [split $paramstring ,] { 1375 - lassign [_parse_dispatch_paramdef $paramdef] paramflags paramtype paramname 1376 - if {[string length $paramname]} { 1377 - lappend paramnames $paramname 1378 - } 1379 - lappend params [list $paramtype [list $paramflags]] 1380 - } 1381 - if {[llength $paramnames] && 1382 - [llength $params] != [llength $paramnames]} { 1383 - error "Missing parameter name in '$paramstring'. All parameter names must be specified or none at all." 1384 - } 1385 - 1386 - lassign [_parse_dispatch_paramdef $rettype] _ rettype name 1387 - set invkind [_string_to_invkind $membertype] 1388 - set proto [list $memid $opts(lcid) $invkind $rettype $params $paramnames] 1389 - lappend parsed_protos $name $proto 1390 - } 1391 - 1392 - set protos [string trim $protos] 1393 - if {[string length $protos]} { 1394 - error "Invalid dispatch prototype: '$protos'" 1395 - } 1396 - 1397 - _dispatch_prototype_load $guid $parsed_protos 1398 -} 1399 - 1400 -# Used to track when interface proxies are renamed/deleted 1401 -proc twapi::_interface_proxy_tracer {ifc oldname newname op} { 1402 - variable _interface_proxies 1403 - if {$op eq "rename"} { 1404 - if {$oldname eq $newname} return 1405 - set _interface_proxies($ifc) $newname 1406 - } else { 1407 - unset _interface_proxies($ifc) 1408 - } 1409 -} 1410 - 1411 - 1412 -# Return a COM interface proxy object for the specified interface. 1413 -# If such an object already exists, it is returned. Otherwise a new one 1414 -# is created. $ifc must be a valid COM Interface pointer for which 1415 -# the caller is holding a reference. Caller relinquishes ownership 1416 -# of the interface and must solely invoke operations through the 1417 -# returned proxy object. When done with the object, call the Release 1418 -# method on it, NOT destroy. 1419 -# TBD - how does this interact with security blankets ? 1420 -proc twapi::make_interface_proxy {ifc} { 1421 - variable _interface_proxies 1422 - 1423 - if {[info exists _interface_proxies($ifc)]} { 1424 - set proxy $_interface_proxies($ifc) 1425 - $proxy AddRef 1426 - if {! [pointer_null? $ifc]} { 1427 - # Release the caller's ref to the interface since we are holding 1428 - # one in the proxy object 1429 - ::twapi::IUnknown_Release $ifc 1430 - } 1431 - } else { 1432 - if {[pointer_null? $ifc]} { 1433 - set proxy [INullProxy new $ifc] 1434 - } else { 1435 - set ifcname [pointer_type $ifc] 1436 - set proxy [${ifcname}Proxy new $ifc] 1437 - } 1438 - set _interface_proxies($ifc) $proxy 1439 - trace add command $proxy {rename delete} [list ::twapi::_interface_proxy_tracer $ifc] 1440 - } 1441 - return $proxy 1442 -} 1443 - 1444 -# "Null" object - clones IUnknownProxy but will raise error on method calls 1445 -# We could have inherited but IUnknownProxy assumes non-null ifc so it 1446 -# and its inherited classes do not have to check for null in every method. 1447 -twapi::class create ::twapi::INullProxy { 1448 - constructor {ifc} { 1449 - my variable _ifc 1450 - # We keep the interface pointer because it encodes type information 1451 - if {! [::twapi::pointer_null? $ifc]} { 1452 - error "Attempt to create a INullProxy with non-NULL interface" 1453 - } 1454 - 1455 - set _ifc $ifc 1456 - 1457 - my variable _nrefs; # Internal ref count (held by app) 1458 - set _nrefs 1 1459 - } 1460 - 1461 - method @Null? {} { return 1 } 1462 - method @Type {} { 1463 - my variable _ifc 1464 - return [::twapi::pointer_type $_ifc] 1465 - } 1466 - method @Type? {type} { 1467 - my variable _ifc 1468 - return [::twapi::pointer? $_ifc $type] 1469 - } 1470 - method AddRef {} { 1471 - my variable _nrefs 1472 - # We maintain our own ref counts. _ifc is null so do not 1473 - # call the COM AddRef ! 1474 - incr _nrefs 1475 - } 1476 - 1477 - method Release {} { 1478 - my variable _nrefs 1479 - if {[incr _nrefs -1] == 0} { 1480 - my destroy 1481 - } 1482 - } 1483 - 1484 - method DebugRefCounts {} { 1485 - my variable _nrefs 1486 - 1487 - # Return out internal ref as well as the COM ones 1488 - # Note latter is always 0 since _ifc is always NULL. 1489 - return [list $_nrefs 0] 1490 - } 1491 - 1492 - method QueryInterface {name_or_iid} { 1493 - error "Attempt to call QueryInterface called on NULL pointer" 1494 - } 1495 - 1496 - method @QueryInterface {name_or_iid} { 1497 - error "Attempt to call QueryInterface called on NULL pointer" 1498 - } 1499 - 1500 - # Parameter is for compatibility with IUnknownProxy 1501 - method @Interface {{addref 1}} { 1502 - my variable _ifc 1503 - return $_ifc 1504 - } 1505 - 1506 - twapi_exportall 1507 -} 1508 - 1509 -twapi::class create ::twapi::IUnknownProxy { 1510 - # Note caller must hold ref on the ifc. This ref is passed to 1511 - # the proxy object and caller must not make use of that ref 1512 - # unless it does an AddRef on it. 1513 - constructor {ifc {objclsid ""}} { 1514 - if {[::twapi::pointer_null? $ifc]} { 1515 - error "Attempt to register a NULL interface" 1516 - } 1517 - 1518 - my variable _ifc 1519 - set _ifc $ifc 1520 - 1521 - my variable _clsid 1522 - set _clsid $objclsid 1523 - 1524 - my variable _blanket; # Security blanket 1525 - set _blanket [list ] 1526 - 1527 - # We keep an internal reference count instead of explicitly 1528 - # calling out to the object's AddRef/Release every time. 1529 - # When the internal ref count goes to 0, we will invoke the 1530 - # object's "native" Release. 1531 - # 1532 - # Note the primary purpose of maintaining our internal reference counts 1533 - # is not efficiency by shortcutting the "native" AddRefs. It is to 1534 - # prevent crashes by bad application code; we can just generate an 1535 - # error instead by having the command go away. 1536 - my variable _nrefs; # Internal ref count (held by app) 1537 - 1538 - set _nrefs 1 1539 - } 1540 - 1541 - destructor { 1542 - my variable _ifc 1543 - ::twapi::IUnknown_Release $_ifc 1544 - } 1545 - 1546 - method AddRef {} { 1547 - my variable _nrefs 1548 - # We maintain our own ref counts. Not pass it on to the actual object 1549 - incr _nrefs 1550 - } 1551 - 1552 - method Release {} { 1553 - my variable _nrefs 1554 - if {[incr _nrefs -1] == 0} { 1555 - my destroy 1556 - } 1557 - } 1558 - 1559 - method DebugRefCounts {} { 1560 - my variable _nrefs 1561 - my variable _ifc 1562 - 1563 - # Return out internal ref as well as the COM ones 1564 - # Note latter are unstable and only to be used for 1565 - # debugging 1566 - twapi::IUnknown_AddRef $_ifc 1567 - return [list $_nrefs [twapi::IUnknown_Release $_ifc]] 1568 - } 1569 - 1570 - method QueryInterface {name_or_iid} { 1571 - my variable _ifc 1572 - lassign [::twapi::_resolve_iid $name_or_iid] iid name 1573 - return [::twapi::Twapi_IUnknown_QueryInterface $_ifc $iid $name] 1574 - } 1575 - 1576 - # Same as QueryInterface except return "" instead of exception 1577 - # if interface not found and returns proxy object instead of interface 1578 - method @QueryInterface {name_or_iid {set_blanket 0}} { 1579 - my variable _blanket 1580 - ::twapi::trap { 1581 - set proxy [::twapi::make_interface_proxy [my QueryInterface $name_or_iid]] 1582 - if {$set_blanket && [llength $_blanket]} { 1583 - $proxy @SetSecurityBlanket $_blanket 1584 - } 1585 - return $proxy 1586 - } onerror {TWAPI_WIN32 0x80004002} { 1587 - # No such interface, return "", don't generate error 1588 - return "" 1589 - } onerror {} { 1590 - if {[info exists proxy]} { 1591 - catch {$proxy Release} 1592 - } 1593 - rethrow 1594 - } 1595 - } 1596 - 1597 - method @Type {} { 1598 - my variable _ifc 1599 - return [::twapi::pointer_type $_ifc] 1600 - } 1601 - 1602 - method @Type? {type} { 1603 - my variable _ifc 1604 - return [::twapi::pointer? $_ifc $type] 1605 - } 1606 - 1607 - method @Null? {} { 1608 - my variable _ifc 1609 - return [::twapi::pointer_null? $_ifc] 1610 - } 1611 - 1612 - # Returns raw interface. Caller must call IUnknown_Release on it 1613 - # iff addref is passed as true (default) 1614 - method @Interface {{addref 1}} { 1615 - my variable _ifc 1616 - if {$addref} { 1617 - ::twapi::IUnknown_AddRef $_ifc 1618 - } 1619 - return $_ifc 1620 - } 1621 - 1622 - # Returns out class id - old deprecated - use GetCLSID 1623 - method @Clsid {} { 1624 - my variable _clsid 1625 - return $_clsid 1626 - } 1627 - 1628 - method @GetCLSID {} { 1629 - my variable _clsid 1630 - return $_clsid 1631 - } 1632 - 1633 - method @SetCLSID {clsid} { 1634 - my variable _clsid 1635 - set _clsid $clsid 1636 - return 1637 - } 1638 - 1639 - method @SetSecurityBlanket blanket { 1640 - my variable _ifc _blanket 1641 - # In-proc components will not support IClientSecurity interface 1642 - # and will raise an error. That's the for the caller to be careful 1643 - # about. 1644 - twapi::CoSetProxyBlanket $_ifc {*}$blanket 1645 - set _blanket $blanket 1646 - return 1647 - } 1648 - 1649 - method @GetSecurityBlanket {} { 1650 - my variable _blanket 1651 - return $_blanket 1652 - } 1653 - 1654 - 1655 - twapi_exportall 1656 -} 1657 - 1658 -twapi::class create ::twapi::IDispatchProxy { 1659 - superclass ::twapi::IUnknownProxy 1660 - 1661 - destructor { 1662 - my variable _typecomp 1663 - if {[info exists _typecomp] && $_typecomp ne ""} { 1664 - $_typecomp Release 1665 - } 1666 - next 1667 - } 1668 - 1669 - method GetTypeInfoCount {} { 1670 - my variable _ifc 1671 - return [::twapi::IDispatch_GetTypeInfoCount $_ifc] 1672 - } 1673 - 1674 - # names is list - method name followed by parameter names 1675 - # Returns list of name dispid pairs 1676 - method GetIDsOfNames {names {lcid 0}} { 1677 - my variable _ifc 1678 - return [::twapi::IDispatch_GetIDsOfNames $_ifc $names $lcid] 1679 - } 1680 - 1681 - # Get dispid of a method (without parameter names) 1682 - method @GetIDOfOneName {name {lcid 0}} { 1683 - return [lindex [my GetIDsOfNames [list $name] $lcid] 1] 1684 - } 1685 - 1686 - method GetTypeInfo {{infotype 0} {lcid 0}} { 1687 - my variable _ifc 1688 - if {$infotype != 0} {error "Parameter infotype must be 0"} 1689 - return [::twapi::IDispatch_GetTypeInfo $_ifc $infotype $lcid] 1690 - } 1691 - 1692 - method @GetTypeInfo {{lcid 0}} { 1693 - return [::twapi::make_interface_proxy [my GetTypeInfo 0 $lcid]] 1694 - } 1695 - 1696 - method Invoke {prototype args} { 1697 - my variable _ifc 1698 - if {[llength $prototype] == 0 && [llength $args] == 0} { 1699 - # Treat as a property get DISPID_VALUE (default value) 1700 - # {dispid=0, lcid=0 cmd=propget(2) ret type=bstr(8) {} (no params)} 1701 - set prototype {0 0 2 8 {}} 1702 - } else { 1703 - # TBD - optimize by precomputing if a prototype needs this processing 1704 - # If any arguments are comobjs, may need to replace with the 1705 - # IDispatch interface. 1706 - # Moreover, we have to manage the reference counts for both 1707 - # IUnknown and IDispatch - 1708 - # - If the parameter is an IN parameter, ref counts do not need 1709 - # to change. 1710 - # - If the parameter is an OUT parameter, we are not passing 1711 - # an interface in, so nothing to do 1712 - # - If the parameter is an INOUT, we need to AddRef it since 1713 - # the COM method will Release it when storing a replacement 1714 - # HERE WE ONLY DO THE CHECK FOR COMOBJ. The AddRef checks are 1715 - # DONE IN THE C CODE (if necessary) 1716 - 1717 - set iarg -1 1718 - set args2 {} 1719 - foreach arg $args { 1720 - incr iarg 1721 - # TBD - optimize this loop 1722 - set argtype [lindex $prototype 4 $iarg 0] 1723 - set argflags 0 1724 - if {[llength [lindex $prototype 4 $iarg 1]]} { 1725 - set argflags [lindex $prototype 4 $iarg 1 0] 1726 - } 1727 - if {$argflags & 1} { 1728 - # IN param 1729 - if {$argflags & 2} { 1730 - # IN/OUT 1731 - # We currently do NOT handle a In/Out - skip for now TBD 1732 - # In the future we will have to check contents of 1733 - # the passed arg as a variable in the CALLER's context 1734 - } else { 1735 - # Pure IN param. Check if it is VT_DISPATCH or 1736 - # VT_VARIANT. Else nothing 1737 - # to do 1738 - if {[lindex $argtype 0] == 26} { 1739 - # Pointer, get base type 1740 - set argtype [lindex $argtype 1] 1741 - } 1742 - if {[lindex $argtype 0] == 9 || [lindex $argtype 0] == 12} { 1743 - # If a comobj was passed, need to extract the 1744 - # dispatch pointer. 1745 - # We do not want change the internal type so 1746 - # save it since comobj? changes it to cmdProc. 1747 - # Moreover, do not check for some types that 1748 - # could not be a comobj. In particular, 1749 - # if a list type, we do not even check 1750 - # because it cannot be a comobj and even checking 1751 - # will result in nested list types being 1752 - # destroyed which affects safearray type detection 1753 - if {[twapi::tcltype $arg] ni {bytecode TwapiOpaque list int double bytearray dict wideInt booleanString}} { 1754 - if {[twapi::comobj? $arg]} { 1755 - # Note we do not addref when getting the interface 1756 - # (last param 0) because not necessary for IN 1757 - # params, AND it is the C code's responsibility 1758 - # anyways 1759 - set arg [$arg -interface 0] 1760 - } 1761 - } 1762 - } 1763 - } 1764 - 1765 - } else { 1766 - # Not an IN param. Nothing to be done 1767 - } 1768 - 1769 - lappend args2 $arg 1770 - } 1771 - set args $args2 1772 - } 1773 - 1774 - # The uplevel is so that if some parameters are output, the varnames 1775 - # are resolved in caller 1776 - uplevel 1 [list ::twapi::IDispatch_Invoke $_ifc $prototype] $args 1777 - } 1778 - 1779 - # Methods are tried in the order specified by invkinds. 1780 - method @Invoke {name invkinds lcid params {namedargs {}}} { 1781 - if {$name eq ""} { 1782 - # Default method 1783 - return [uplevel 1 [list [self] Invoke {}] $params] 1784 - } else { 1785 - set nparams [llength $params] 1786 - 1787 - # We will try for each invkind to match. matches can be of 1788 - # different degrees, in descending priority - 1789 - # 1. prototype has parameter info and num params match exactly 1790 - # 2. prototype has parameter info and num params is greater 1791 - # than supplied arguments (assumes others have defaults) 1792 - # 3. prototype has no parameter information 1793 - # Within these classes, the order of invkinds determines 1794 - # priority 1795 - 1796 - foreach invkind $invkinds { 1797 - set proto [my @Prototype $name $invkind $lcid] 1798 - if {[llength $proto]} { 1799 - if {[llength $proto] < 5} { 1800 - # No parameter information 1801 - lappend class3 $proto 1802 - } else { 1803 - if {[llength [lindex $proto 4]] == $nparams} { 1804 - lappend class1 $proto 1805 - break; # Class 1 match, no need to try others 1806 - } elseif {[llength [lindex $proto 4]] > $nparams} { 1807 - lappend class2 $proto 1808 - } else { 1809 - # Ignore - proto has fewer than supplied params 1810 - # Could not be a match 1811 - } 1812 - } 1813 - } 1814 - } 1815 - 1816 - # For exact match (class1), we do not need the named arguments as 1817 - # positional arguments take priority. When number of passed parameters 1818 - # is fewer than those in prototype, check named arguments and use those 1819 - # values. If no parameter information, we can't use named arguments 1820 - # anyways. 1821 - if {[info exists class1]} { 1822 - set proto [lindex $class1 0] 1823 - } elseif {[info exists class2]} { 1824 - set proto [lindex $class2 0] 1825 - # If we are passed named arguments AND the prototype also 1826 - # has parameter name information, replace the default values 1827 - # in the parameter definitions with the named arg value if 1828 - # it exists. 1829 - if {[llength $namedargs] && 1830 - [llength [set paramnames [lindex $proto 5]]]} { 1831 - foreach {paramname paramval} $namedargs { 1832 - set paramindex [lsearch -nocase $paramnames $paramname] 1833 - if {$paramindex < 0} { 1834 - twapi::win32_error 0x80020004 "No parameter with name '$paramname' found for method '$name'" 1835 - } 1836 - 1837 - # Set the default value field of the 1838 - # appropriate parameter to the named arg value 1839 - set paramtype [lindex $proto 4 $paramindex 0] 1840 - 1841 - # If parameter is VT_DISPATCH or VT_VARIANT, 1842 - # convert from comobj if necessary. 1843 - if {$paramtype == 9 || $paramtype == 12} { 1844 - # We do not want to change the internal type by 1845 - # shimmering. See similar comments in Invoke 1846 - if {[twapi::tcltype $paramval] ni {"" TwapiOpaque list int double bytearray dict wideInt booleanString}} { 1847 - if {[::twapi::comobj? $paramval]} { 1848 - # Note no AddRef when getting the interface 1849 - # (last param 0) because it is the C code's 1850 - # responsibility based on in/out direction 1851 - set paramval [$paramval -interface 0] 1852 - } 1853 - } 1854 - } 1855 - 1856 - # Replace the default value field for that param def 1857 - lset proto 4 $paramindex [linsert [lrange [lindex $proto 4 $paramindex] 0 1] 2 $paramval] 1858 - } 1859 - } 1860 - } elseif {[info exists class3]} { 1861 - set proto [lindex $class3 0] 1862 - } else { 1863 - # No prototype via typecomp / typeinfo available. No lcid worked. 1864 - # We have to use the last resort of GetIDsOfNames 1865 - set dispid [my @GetIDOfOneName [list $name] 0] 1866 - # TBD - should we cache result ? Probably not. 1867 - if {$dispid ne ""} { 1868 - # Note params field (last) is missing signifying we do not 1869 - # know prototypes 1870 - set proto [list $dispid 0 [lindex $invkinds 0] 8] 1871 - } else { 1872 - twapi::win32_error 0x80020003 "No property or method found with name '$name'." 1873 - } 1874 - } 1875 - 1876 - # Need uplevel so by-ref param vars are resolved correctly 1877 - return [uplevel 1 [list [self] Invoke $proto] $params] 1878 - } 1879 - } 1880 - 1881 - # Get prototype that match the specified name 1882 - method @Prototype {name invkind lcid} { 1883 - my variable _ifc _guid _typecomp 1884 - 1885 - # Always need the GUID so get it we have not done so already 1886 - if {![info exists _guid]} { 1887 - my @InitTypeCompAndGuid 1888 - } 1889 - # Note above call may still have failed to init _guid 1890 - 1891 - # If we have been through here before and have our guid, 1892 - # check if a prototype exists and return it. 1893 - if {[info exists _guid] && $_guid ne "" && 1894 - [::twapi::_dispatch_prototype_get $_guid $name $lcid $invkind proto]} { 1895 - return $proto 1896 - } 1897 - 1898 - # Not in cache, have to look for it 1899 - # Use the ITypeComp for this interface if we do not 1900 - # already have it. We trap any errors because we will retry with 1901 - # different LCID's below. 1902 - set proto {} 1903 - if {![info exists _typecomp]} { 1904 - my @InitTypeCompAndGuid 1905 - } 1906 - if {$_typecomp ne ""} { 1907 - ::twapi::trap { 1908 - 1909 - set invkind [::twapi::_string_to_invkind $invkind] 1910 - set lhash [::twapi::LHashValOfName $lcid $name] 1911 - 1912 - if {![catch {$_typecomp Bind $name $lhash $invkind} binddata] && 1913 - [llength $binddata]} { 1914 - lassign $binddata type data ifc 1915 - if {$type eq "funcdesc" || 1916 - ($type eq "vardesc" && [::twapi::kl_get $data varkind] == 3)} { 1917 - set params {} 1918 - set bindti [::twapi::make_interface_proxy $ifc] 1919 - ::twapi::trap { 1920 - set params [::twapi::_resolve_params_for_prototype $bindti [::twapi::kl_get $data lprgelemdescParam]] 1921 - # Param names are needed for named arguments. Index 0 is method name so skip it 1922 - if {[catch {lrange [$bindti GetNames [twapi::kl_get $data memid]] 1 end} paramnames]} { 1923 - set paramnames {} 1924 - } 1925 - } finally { 1926 - $bindti Release 1927 - } 1928 - set proto [list [::twapi::kl_get $data memid] \ 1929 - $lcid \ 1930 - $invkind \ 1931 - [::twapi::kl_get $data elemdescFunc.tdesc] \ 1932 - $params $paramnames] 1933 - } else { 1934 - ::twapi::IUnknown_Release $ifc; # Don't need ifc but must release 1935 - twapi::debuglog "IDispatchProxy::@Prototype: Unexpected Bind type: $type, data: $data" 1936 - } 1937 - } 1938 - } onerror {} { 1939 - # Ignore and retry with other LCID's below 1940 - } 1941 - } 1942 - 1943 - 1944 - # If we do not have a guid return because even if we do not 1945 - # have a proto yet, falling through to try another lcid will not 1946 - # help and in fact will cause infinite recursion. 1947 - 1948 - if {$_guid eq ""} { 1949 - return $proto 1950 - } 1951 - 1952 - # We do have a guid, store the proto in cache (even if negative) 1953 - ::twapi::dispatch_prototype_set $_guid $name $lcid $invkind $proto 1954 - 1955 - # If we have the proto return it 1956 - if {[llength $proto]} { 1957 - return $proto 1958 - } 1959 - 1960 - # Could not find a matching prototype from the typeinfo/typecomp. 1961 - # We are not done yet. We will try and fall back to other lcid's 1962 - # Note we do this AFTER setting the prototype in the cache. That 1963 - # way we prevent (infinite) mutual recursion between lcid fallbacks. 1964 - # The fallback sequence is $lcid -> 0 -> 1033 1965 - # (1033 is US English). Note lcid could itself be 1033 1966 - # default and land up being checked twice times but that's 1967 - # ok since that's a one-time thing, and not very expensive either 1968 - # since the second go-around will hit the cache (negative). 1969 - # Note the time this is really useful is when the cache has 1970 - # been populated explicitly from a type library since in that 1971 - # case many interfaces land up with a US ENglish lcid (MSI being 1972 - # just one example) 1973 - 1974 - if {$lcid == 0} { 1975 - # Note this call may further recurse and return either a 1976 - # proto or empty (fail) 1977 - set proto [my @Prototype $name $invkind 1033] 1978 - } else { 1979 - set proto [my @Prototype $name $invkind 0] 1980 - } 1981 - 1982 - # Store it as *original* lcid. 1983 - ::twapi::dispatch_prototype_set $_guid $name $lcid $invkind $proto 1984 - 1985 - return $proto 1986 - } 1987 - 1988 - 1989 - # Initialize _typecomp and _guid. Not in constructor because may 1990 - # not always be required. Raises error if not available 1991 - method @InitTypeCompAndGuid {} { 1992 - my variable _guid _typecomp 1993 - 1994 - if {[info exists _typecomp]} { 1995 - # Based on code below, if _typecomp exists 1996 - # _guid also exists so no need to check for that 1997 - return 1998 - } 1999 - 2000 - ::twapi::trap { 2001 - set ti [my @GetTypeInfo 0] 2002 - } onerror {} { 2003 - # We do not raise an error because 2004 - # even without the _typecomp we can try invoking 2005 - # methods via IDispatch::GetIDsOfNames 2006 - twapi::debuglog "Could not ITypeInfo: [twapi::trapresult]" 2007 - if {![info exists _guid]} { 2008 - # Do not overwrite if already set thru @SetGuid or constructor 2009 - # Set to empty otherwise so we know we tried and failed 2010 - set _guid "" 2011 - } 2012 - set _typecomp "" 2013 - return 2014 - } 2015 - 2016 - ::twapi::trap { 2017 - # In case of dual interfaces, we need the typeinfo for the 2018 - # dispatch. Again, errors handled in try handlers 2019 - switch -exact -- [::twapi::kl_get [$ti GetTypeAttr] typekind] { 2020 - 4 { 2021 - # Dispatch type, fine, just what we want 2022 - } 2023 - 3 { 2024 - # Interface type, Get the dispatch interface 2025 - set ti2 [$ti @GetRefTypeInfo [$ti GetRefTypeOfImplType -1]] 2026 - $ti Release 2027 - set ti $ti2 2028 - } 2029 - default { 2030 - error "Interface is not a dispatch interface" 2031 - } 2032 - } 2033 - if {![info exists _guid]} { 2034 - # _guid might have already been valid, do not overwrite 2035 - set _guid [::twapi::kl_get [$ti GetTypeAttr] guid] 2036 - } 2037 - set _typecomp [$ti @GetTypeComp]; # ITypeComp 2038 - } finally { 2039 - $ti Release 2040 - } 2041 - } 2042 - 2043 - # Some COM objects like MSI do not have TypeInfo interfaces from 2044 - # where the GUID and TypeComp can be extracted. So we allow caller 2045 - # to explicitly set the GUID so we can look up methods in the 2046 - # dispatch prototype cache if it was populated directly by the 2047 - # application. If guid is not a valid GUID, an attempt is made 2048 - # to look it up as an IID name. 2049 - method @SetGuid {guid} { 2050 - my variable _guid 2051 - if {$guid eq ""} { 2052 - if {![info exists _guid]} { 2053 - my @InitTypeCompAndGuid 2054 - } 2055 - } else { 2056 - if {![::twapi::Twapi_IsValidGUID $guid]} { 2057 - set resolved_guid [::twapi::name_to_iid $guid] 2058 - if {$resolved_guid eq ""} { 2059 - error "Could not resolve $guid to a Interface GUID." 2060 - } 2061 - set guid $resolved_guid 2062 - } 2063 - 2064 - if {[info exists _guid] && $_guid ne ""} { 2065 - if {[string compare -nocase $guid $_guid]} { 2066 - error "Attempt to set the GUID to $guid when the dispatch proxy has already been initialized to $_guid" 2067 - } 2068 - } else { 2069 - set _guid $guid 2070 - } 2071 - } 2072 - 2073 - return $_guid 2074 - } 2075 - 2076 - method @GetCoClassTypeInfo {} { 2077 - my variable _ifc 2078 - 2079 - # We can get the typeinfo for the coclass in one of two ways: 2080 - # If the object supports IProvideClassInfo, we use it. Else 2081 - # we try the following: 2082 - # - from the idispatch, we get its typeinfo 2083 - # - from the typeinfo, we get the containing typelib 2084 - # - then we search the typelib for the coclass clsid 2085 - 2086 - ::twapi::trap { 2087 - set pci_ifc [my QueryInterface IProvideClassInfo] 2088 - set ti_ifc [::twapi::IProvideClassInfo_GetClassInfo $pci_ifc] 2089 - return [::twapi::make_interface_proxy $ti_ifc] 2090 - } onerror {} { 2091 - # Ignore - try the longer route if we were given the coclass clsid 2092 - } finally { 2093 - if {[info exists pci_ifc]} { 2094 - ::twapi::IUnknown_Release $pci_ifc 2095 - } 2096 - # Note - do not do anything with ti_ifc here, EVEN on error 2097 - } 2098 - 2099 - set co_clsid [my @Clsid] 2100 - if {$co_clsid eq ""} { 2101 - # E_FAIL 2102 - twapi::win32_error 0x80004005 "Could not get ITypeInfo for coclass: object does not support IProvideClassInfo and clsid not specified." 2103 - } 2104 - 2105 - set ti [my @GetTypeInfo] 2106 - ::twapi::trap { 2107 - set tl [lindex [$ti @GetContainingTypeLib] 0] 2108 - if {0} { 2109 - $tl @Foreach -guid $co_clsid -type coclass coti { 2110 - break 2111 - } 2112 - if {[info exists coti]} { 2113 - return $coti 2114 - } 2115 - } else { 2116 - return [$tl @GetTypeInfoOfGuid $co_clsid] 2117 - } 2118 - twapi::win32_error 0x80004005 "Could not find coclass."; # E_FAIL 2119 - } finally { 2120 - if {[info exists ti]} { 2121 - $ti Release 2122 - } 2123 - if {[info exists tl]} { 2124 - $tl Release 2125 - } 2126 - } 2127 - } 2128 - 2129 - twapi_exportall 2130 -} 2131 - 2132 - 2133 -twapi::class create ::twapi::IDispatchExProxy { 2134 - superclass ::twapi::IDispatchProxy 2135 - 2136 - method DeleteMemberByDispID {dispid} { 2137 - my variable _ifc 2138 - return [::twapi::IDispatchEx_DeleteMemberByDispID $_ifc $dispid] 2139 - } 2140 - 2141 - method DeleteMemberByName {name {lcid 0}} { 2142 - my variable _ifc 2143 - return [::twapi::IDispatchEx_DeleteMemberByName $_ifc $name $lcid] 2144 - } 2145 - 2146 - method GetDispID {name flags} { 2147 - my variable _ifc 2148 - return [::twapi::IDispatchEx_GetDispID $_ifc $name $flags] 2149 - } 2150 - 2151 - method GetMemberName {dispid} { 2152 - my variable _ifc 2153 - return [::twapi::IDispatchEx_GetMemberName $_ifc $dispid] 2154 - } 2155 - 2156 - method GetMemberProperties {dispid flags} { 2157 - my variable _ifc 2158 - return [::twapi::IDispatchEx_GetMemberProperties $_ifc $dispid $flags] 2159 - } 2160 - 2161 - # For some reason, order of args is different for this call! 2162 - method GetNextDispID {flags dispid} { 2163 - my variable _ifc 2164 - return [::twapi::IDispatchEx_GetNextDispID $_ifc $flags $dispid] 2165 - } 2166 - 2167 - method GetNameSpaceParent {} { 2168 - my variable _ifc 2169 - return [::twapi::IDispatchEx_GetNameSpaceParent $_ifc] 2170 - } 2171 - 2172 - method @GetNameSpaceParent {} { 2173 - return [::twapi::make_interface_proxy [my GetNameSpaceParent]] 2174 - } 2175 - 2176 - method @Prototype {name invkind {lcid 0}} { 2177 - set invkind [::twapi::_string_to_invkind $invkind] 2178 - 2179 - # First try IDispatch 2180 - ::twapi::trap { 2181 - set proto [next $name $invkind $lcid] 2182 - if {[llength $proto]} { 2183 - return $proto 2184 - } 2185 - # Note negative results ignored, as new members may be added/deleted 2186 - # to an IDispatchEx at any time. We will try below another way. 2187 - 2188 - } onerror {} { 2189 - # Ignore the error - we will try below using another method 2190 - } 2191 - 2192 - # Not a simple dispatch interface method. Could be expando 2193 - # type which is dynamically created. NOTE: The member is NOT 2194 - # created until the GetDispID call is made. 2195 - 2196 - # 10 -> case insensitive, create if required 2197 - set dispid [my GetDispID $name 10] 2198 - 2199 - # IMPORTANT : prototype retrieval results MUST NOT be cached since 2200 - # underlying object may add/delete members at any time. 2201 - 2202 - # No type information is available for dynamic members. 2203 - # TBD - is that really true? 2204 - 2205 - # Invoke kind - 1 (method), 2 (propget), 4 (propput) 2206 - if {$invkind == 1} { 2207 - # method 2208 - set flags 0x100 2209 - } elseif {$invkind == 2} { 2210 - # propget 2211 - set flags 0x1 2212 - } elseif {$invkind == 4} { 2213 - # propput 2214 - set flags 0x4 2215 - } else { 2216 - # TBD - what about putref (flags 0x10) 2217 - error "Internal error: Invalid invkind value $invkind" 2218 - } 2219 - 2220 - # Try at least getting the invocation type but even that is not 2221 - # supported by all objects in which case we assume it can be invoked. 2222 - # TBD - in that case, why even bother doing GetMemberProperties? 2223 - if {! [catch { 2224 - set flags [expr {[my GetMemberProperties 0x115] & $flags}] 2225 - }]} { 2226 - if {! $flags} { 2227 - return {}; # EMpty proto -> no valid name for this invkind 2228 - } 2229 - } 2230 - 2231 - # Valid invkind or object does not support GetMemberProperties 2232 - # Return type is 8 (BSTR) but does not really matter as 2233 - # actual type will be set based on what is returned. 2234 - return [list $dispid $lcid $invkind 8] 2235 - } 2236 - 2237 - twapi_exportall 2238 -} 2239 - 2240 - 2241 -# ITypeInfo 2242 -#----------- 2243 - 2244 -twapi::class create ::twapi::ITypeInfoProxy { 2245 - superclass ::twapi::IUnknownProxy 2246 - 2247 - method GetRefTypeOfImplType {index} { 2248 - my variable _ifc 2249 - return [::twapi::ITypeInfo_GetRefTypeOfImplType $_ifc $index] 2250 - } 2251 - 2252 - method GetDocumentation {memid} { 2253 - my variable _ifc 2254 - return [::twapi::ITypeInfo_GetDocumentation $_ifc $memid] 2255 - } 2256 - 2257 - method GetImplTypeFlags {index} { 2258 - my variable _ifc 2259 - return [::twapi::ITypeInfo_GetImplTypeFlags $_ifc $index] 2260 - } 2261 - 2262 - method GetNames {index} { 2263 - my variable _ifc 2264 - return [::twapi::ITypeInfo_GetNames $_ifc $index] 2265 - } 2266 - 2267 - method GetTypeAttr {} { 2268 - my variable _ifc 2269 - return [::twapi::ITypeInfo_GetTypeAttr $_ifc] 2270 - } 2271 - 2272 - method GetFuncDesc {index} { 2273 - my variable _ifc 2274 - return [::twapi::ITypeInfo_GetFuncDesc $_ifc $index] 2275 - } 2276 - 2277 - method GetVarDesc {index} { 2278 - my variable _ifc 2279 - return [::twapi::ITypeInfo_GetVarDesc $_ifc $index] 2280 - } 2281 - 2282 - method GetIDsOfNames {names} { 2283 - my variable _ifc 2284 - return [::twapi::ITypeInfo_GetIDsOfNames $_ifc $names] 2285 - } 2286 - 2287 - method GetRefTypeInfo {hreftype} { 2288 - my variable _ifc 2289 - return [::twapi::ITypeInfo_GetRefTypeInfo $_ifc $hreftype] 2290 - } 2291 - 2292 - method @GetRefTypeInfo {hreftype} { 2293 - return [::twapi::make_interface_proxy [my GetRefTypeInfo $hreftype]] 2294 - } 2295 - 2296 - method GetTypeComp {} { 2297 - my variable _ifc 2298 - return [::twapi::ITypeInfo_GetTypeComp $_ifc] 2299 - } 2300 - 2301 - method @GetTypeComp {} { 2302 - return [::twapi::make_interface_proxy [my GetTypeComp]] 2303 - } 2304 - 2305 - method GetContainingTypeLib {} { 2306 - my variable _ifc 2307 - return [::twapi::ITypeInfo_GetContainingTypeLib $_ifc] 2308 - } 2309 - 2310 - method @GetContainingTypeLib {} { 2311 - lassign [my GetContainingTypeLib] itypelib index 2312 - return [list [::twapi::make_interface_proxy $itypelib] $index] 2313 - } 2314 - 2315 - method @GetRefTypeInfoFromIndex {index} { 2316 - return [my @GetRefTypeInfo [my GetRefTypeOfImplType $index]] 2317 - } 2318 - 2319 - # Friendlier version of GetTypeAttr 2320 - method @GetTypeAttr {args} { 2321 - 2322 - array set opts [::twapi::parseargs args { 2323 - all 2324 - guid 2325 - lcid 2326 - constructorid 2327 - destructorid 2328 - schema 2329 - instancesize 2330 - typekind 2331 - fncount 2332 - varcount 2333 - interfacecount 2334 - vtblsize 2335 - alignment 2336 - majorversion 2337 - minorversion 2338 - aliasdesc 2339 - flags 2340 - idldesc 2341 - memidmap 2342 - } -maxleftover 0] 2343 - 2344 - array set data [my GetTypeAttr] 2345 - set result [list ] 2346 - foreach {opt key} { 2347 - guid guid 2348 - lcid lcid 2349 - constructorid memidConstructor 2350 - destructorid memidDestructor 2351 - schema lpstrSchema 2352 - instancesize cbSizeInstance 2353 - fncount cFuncs 2354 - varcount cVars 2355 - interfacecount cImplTypes 2356 - vtblsize cbSizeVft 2357 - alignment cbAlignment 2358 - majorversion wMajorVerNum 2359 - minorversion wMinorVerNum 2360 - aliasdesc tdescAlias 2361 - } { 2362 - if {$opts(all) || $opts($opt)} { 2363 - lappend result -$opt $data($key) 2364 - } 2365 - } 2366 - 2367 - if {$opts(all) || $opts(typekind)} { 2368 - set typekind $data(typekind) 2369 - if {[info exists ::twapi::_typekind_map($typekind)]} { 2370 - set typekind $::twapi::_typekind_map($typekind) 2371 - } 2372 - lappend result -typekind $typekind 2373 - } 2374 - 2375 - if {$opts(all) || $opts(flags)} { 2376 - lappend result -flags [::twapi::_make_symbolic_bitmask $data(wTypeFlags) { 2377 - appobject 1 2378 - cancreate 2 2379 - licensed 4 2380 - predeclid 8 2381 - hidden 16 2382 - control 32 2383 - dual 64 2384 - nonextensible 128 2385 - oleautomation 256 2386 - restricted 512 2387 - aggregatable 1024 2388 - replaceable 2048 2389 - dispatchable 4096 2390 - reversebind 8192 2391 - proxy 16384 2392 - }] 2393 - } 2394 - 2395 - if {$opts(all) || $opts(idldesc)} { 2396 - lappend result -idldesc [::twapi::_make_symbolic_bitmask $data(idldescType) { 2397 - in 1 2398 - out 2 2399 - lcid 4 2400 - retval 8 2401 - }] 2402 - } 2403 - 2404 - if {$opts(all) || $opts(memidmap)} { 2405 - set memidmap [list ] 2406 - for {set i 0} {$i < $data(cFuncs)} {incr i} { 2407 - array set fninfo [my @GetFuncDesc $i -memid -name] 2408 - lappend memidmap $fninfo(-memid) $fninfo(-name) 2409 - } 2410 - lappend result -memidmap $memidmap 2411 - } 2412 - 2413 - return $result 2414 - } 2415 - 2416 - # 2417 - # Get a variable description associated with a type 2418 - method @GetVarDesc {index args} { 2419 - # TBD - add support for retrieving elemdescVar.paramdesc fields 2420 - 2421 - array set opts [::twapi::parseargs args { 2422 - all 2423 - name 2424 - memid 2425 - schema 2426 - datatype 2427 - value 2428 - valuetype 2429 - varkind 2430 - flags 2431 - } -maxleftover 0] 2432 - 2433 - array set data [my GetVarDesc $index] 2434 - 2435 - set result [list ] 2436 - foreach {opt key} { 2437 - memid memid 2438 - schema lpstrSchema 2439 - datatype elemdescVar.tdesc 2440 - } { 2441 - if {$opts(all) || $opts($opt)} { 2442 - lappend result -$opt $data($key) 2443 - } 2444 - } 2445 - 2446 - 2447 - if {$opts(all) || $opts(value)} { 2448 - if {[info exists data(lpvarValue)]} { 2449 - # Const value 2450 - lappend result -value [lindex $data(lpvarValue) 1] 2451 - } else { 2452 - lappend result -value $data(oInst) 2453 - } 2454 - } 2455 - 2456 - if {$opts(all) || $opts(valuetype)} { 2457 - if {[info exists data(lpvarValue)]} { 2458 - lappend result -valuetype [lindex $data(lpvarValue) 0] 2459 - } else { 2460 - lappend result -valuetype int 2461 - } 2462 - } 2463 - 2464 - if {$opts(all) || $opts(varkind)} { 2465 - lappend result -varkind [::twapi::kl_get { 2466 - 0 perinstance 2467 - 1 static 2468 - 2 const 2469 - 3 dispatch 2470 - } $data(varkind) $data(varkind)] 2471 - } 2472 - 2473 - if {$opts(all) || $opts(flags)} { 2474 - lappend result -flags [::twapi::_make_symbolic_bitmask $data(wVarFlags) { 2475 - readonly 1 2476 - source 2 2477 - bindable 4 2478 - requestedit 8 2479 - displaybind 16 2480 - defaultbind 32 2481 - hidden 64 2482 - restricted 128 2483 - defaultcollelem 256 2484 - uidefault 512 2485 - nonbrowsable 1024 2486 - replaceable 2048 2487 - immediatebind 4096 2488 - }] 2489 - } 2490 - 2491 - if {$opts(all) || $opts(name)} { 2492 - set result [concat $result [my @GetDocumentation $data(memid) -name]] 2493 - } 2494 - 2495 - return $result 2496 - } 2497 - 2498 - method @GetFuncDesc {index args} { 2499 - array set opts [::twapi::parseargs args { 2500 - all 2501 - name 2502 - memid 2503 - funckind 2504 - invkind 2505 - callconv 2506 - params 2507 - paramnames 2508 - flags 2509 - datatype 2510 - resultcodes 2511 - vtbloffset 2512 - } -maxleftover 0] 2513 - 2514 - array set data [my GetFuncDesc $index] 2515 - set result [list ] 2516 - 2517 - if {$opts(all) || $opts(paramnames)} { 2518 - lappend result -paramnames [lrange [my GetNames $data(memid)] 1 end] 2519 - } 2520 - foreach {opt key} { 2521 - memid memid 2522 - vtbloffset oVft 2523 - datatype elemdescFunc.tdesc 2524 - resultcodes lprgscode 2525 - } { 2526 - if {$opts(all) || $opts($opt)} { 2527 - lappend result -$opt $data($key) 2528 - } 2529 - } 2530 - 2531 - if {$opts(all) || $opts(funckind)} { 2532 - lappend result -funckind [::twapi::kl_get { 2533 - 0 virtual 2534 - 1 purevirtual 2535 - 2 nonvirtual 2536 - 3 static 2537 - 4 dispatch 2538 - } $data(funckind) $data(funckind)] 2539 - } 2540 - 2541 - if {$opts(all) || $opts(invkind)} { 2542 - lappend result -invkind [::twapi::_string_to_invkind $data(invkind)] 2543 - } 2544 - 2545 - if {$opts(all) || $opts(callconv)} { 2546 - lappend result -callconv [::twapi::kl_get { 2547 - 0 fastcall 2548 - 1 cdecl 2549 - 2 pascal 2550 - 3 macpascal 2551 - 4 stdcall 2552 - 5 fpfastcall 2553 - 6 syscall 2554 - 7 mpwcdecl 2555 - 8 mpwpascal 2556 - } $data(callconv) $data(callconv)] 2557 - } 2558 - 2559 - if {$opts(all) || $opts(flags)} { 2560 - lappend result -flags [::twapi::_make_symbolic_bitmask $data(wFuncFlags) { 2561 - restricted 1 2562 - source 2 2563 - bindable 4 2564 - requestedit 8 2565 - displaybind 16 2566 - defaultbind 32 2567 - hidden 64 2568 - usesgetlasterror 128 2569 - defaultcollelem 256 2570 - uidefault 512 2571 - nonbrowsable 1024 2572 - replaceable 2048 2573 - immediatebind 4096 2574 - }] 2575 - } 2576 - 2577 - if {$opts(all) || $opts(params)} { 2578 - set params [list ] 2579 - foreach param $data(lprgelemdescParam) { 2580 - lassign $param paramtype paramdesc 2581 - set paramflags [::twapi::_paramflags_to_tokens [lindex $paramdesc 0]] 2582 - if {[llength $paramdesc] > 1} { 2583 - # There is a default value associated with the parameter 2584 - lappend params [list $paramtype $paramflags [lindex $paramdesc 1]] 2585 - } else { 2586 - lappend params [list $paramtype $paramflags] 2587 - } 2588 - } 2589 - lappend result -params $params 2590 - } 2591 - 2592 - if {$opts(all) || $opts(name)} { 2593 - set result [concat $result [my @GetDocumentation $data(memid) -name]] 2594 - } 2595 - 2596 - return $result 2597 - } 2598 - 2599 - # 2600 - # Get documentation for a element of a type 2601 - method @GetDocumentation {memid args} { 2602 - array set opts [::twapi::parseargs args { 2603 - all 2604 - name 2605 - docstring 2606 - helpctx 2607 - helpfile 2608 - } -maxleftover 0] 2609 - 2610 - lassign [my GetDocumentation $memid] name docstring helpctx helpfile 2611 - 2612 - set result [list ] 2613 - foreach opt {name docstring helpctx helpfile} { 2614 - if {$opts(all) || $opts($opt)} { 2615 - lappend result -$opt [set $opt] 2616 - } 2617 - } 2618 - return $result 2619 - } 2620 - 2621 - method @GetName {{memid -1}} { 2622 - return [lindex [my @GetDocumentation $memid -name] 1] 2623 - } 2624 - 2625 - method @GetImplTypeFlags {index} { 2626 - return [::twapi::_make_symbolic_bitmask \ 2627 - [my GetImplTypeFlags $index] \ 2628 - { 2629 - default 1 2630 - source 2 2631 - restricted 4 2632 - defaultvtable 8 2633 - }] 2634 - } 2635 - 2636 - # 2637 - # Get the typeinfo for the default source interface of a coclass 2638 - # This object must be the typeinfo of the coclass 2639 - method @GetDefaultSourceTypeInfo {} { 2640 - set count [lindex [my @GetTypeAttr -interfacecount] 1] 2641 - for {set i 0} {$i < $count} {incr i} { 2642 - set flags [my GetImplTypeFlags $i] 2643 - # default 0x1, source 0x2 2644 - if {($flags & 3) == 3} { 2645 - # Our source interface implementation can only handle IDispatch 2646 - # so check if the source interface is that else keep looking. 2647 - # We even ignore dual interfaces because we cannot then 2648 - # assume caller will use the dispatch version 2649 - set ti [my @GetRefTypeInfoFromIndex $i] 2650 - array set typeinfo [$ti GetTypeAttr] 2651 - # typekind == 4 -> IDispatch, 2652 - # flags - 0x1000 -> dispatchable, 0x40 -> dual 2653 - if {$typeinfo(typekind) == 4 && 2654 - ($typeinfo(wTypeFlags) & 0x1000) && 2655 - !($typeinfo(wTypeFlags) & 0x40)} { 2656 - return $ti 2657 - } 2658 - $ti destroy 2659 - } 2660 - } 2661 - return "" 2662 - } 2663 - 2664 - twapi_exportall 2665 -} 2666 - 2667 - 2668 -# ITypeLib 2669 -#---------- 2670 - 2671 -twapi::class create ::twapi::ITypeLibProxy { 2672 - superclass ::twapi::IUnknownProxy 2673 - 2674 - method GetDocumentation {index} { 2675 - my variable _ifc 2676 - return [::twapi::ITypeLib_GetDocumentation $_ifc $index] 2677 - } 2678 - method GetTypeInfoCount {} { 2679 - my variable _ifc 2680 - return [::twapi::ITypeLib_GetTypeInfoCount $_ifc] 2681 - } 2682 - method GetTypeInfoType {index} { 2683 - my variable _ifc 2684 - return [::twapi::ITypeLib_GetTypeInfoType $_ifc $index] 2685 - } 2686 - method GetLibAttr {} { 2687 - my variable _ifc 2688 - return [::twapi::ITypeLib_GetLibAttr $_ifc] 2689 - } 2690 - method GetTypeInfo {index} { 2691 - my variable _ifc 2692 - return [::twapi::ITypeLib_GetTypeInfo $_ifc $index] 2693 - } 2694 - method @GetTypeInfo {index} { 2695 - return [::twapi::make_interface_proxy [my GetTypeInfo $index]] 2696 - } 2697 - method GetTypeInfoOfGuid {guid} { 2698 - my variable _ifc 2699 - return [::twapi::ITypeLib_GetTypeInfoOfGuid $_ifc $guid] 2700 - } 2701 - method @GetTypeInfoOfGuid {guid} { 2702 - return [::twapi::make_interface_proxy [my GetTypeInfoOfGuid $guid]] 2703 - } 2704 - method @GetTypeInfoType {index} { 2705 - set typekind [my GetTypeInfoType $index] 2706 - if {[info exists ::twapi::_typekind_map($typekind)]} { 2707 - set typekind $::twapi::_typekind_map($typekind) 2708 - } 2709 - return $typekind 2710 - } 2711 - 2712 - method @GetDocumentation {id args} { 2713 - array set opts [::twapi::parseargs args { 2714 - all 2715 - name 2716 - docstring 2717 - helpctx 2718 - helpfile 2719 - } -maxleftover 0] 2720 - 2721 - lassign [my GetDocumentation $id] name docstring helpctx helpfile 2722 - set result [list ] 2723 - foreach opt {name docstring helpctx helpfile} { 2724 - if {$opts(all) || $opts($opt)} { 2725 - lappend result -$opt [set $opt] 2726 - } 2727 - } 2728 - return $result 2729 - } 2730 - 2731 - method @GetName {} { 2732 - return [lindex [my GetDocumentation -1] 0] 2733 - } 2734 - 2735 - method @GetLibAttr {args} { 2736 - array set opts [::twapi::parseargs args { 2737 - all 2738 - guid 2739 - lcid 2740 - syskind 2741 - majorversion 2742 - minorversion 2743 - flags 2744 - } -maxleftover 0] 2745 - 2746 - array set data [my GetLibAttr] 2747 - set result [list ] 2748 - foreach {opt key} { 2749 - guid guid 2750 - lcid lcid 2751 - majorversion wMajorVerNum 2752 - minorversion wMinorVerNum 2753 - } { 2754 - if {$opts(all) || $opts($opt)} { 2755 - lappend result -$opt $data($key) 2756 - } 2757 - } 2758 - 2759 - if {$opts(all) || $opts(flags)} { 2760 - lappend result -flags [::twapi::_make_symbolic_bitmask $data(wLibFlags) { 2761 - restricted 1 2762 - control 2 2763 - hidden 4 2764 - hasdiskimage 8 2765 - }] 2766 - } 2767 - 2768 - if {$opts(all) || $opts(syskind)} { 2769 - lappend result -syskind [::twapi::kl_get { 2770 - 0 win16 2771 - 1 win32 2772 - 2 mac 2773 - } $data(syskind) $data(syskind)] 2774 - } 2775 - 2776 - return $result 2777 - } 2778 - 2779 - # 2780 - # Iterate through a typelib. Caller is responsible for releasing 2781 - # each ITypeInfo passed to it 2782 - # 2783 - method @Foreach {args} { 2784 - 2785 - array set opts [::twapi::parseargs args { 2786 - type.arg 2787 - name.arg 2788 - guid.arg 2789 - } -maxleftover 2 -nulldefault] 2790 - 2791 - if {[llength $args] != 2} { 2792 - error "Syntax error: Should be '[self] @Foreach ?options? VARNAME SCRIPT'" 2793 - } 2794 - 2795 - lassign $args varname script 2796 - upvar $varname varti 2797 - 2798 - set count [my GetTypeInfoCount] 2799 - for {set i 0} {$i < $count} {incr i} { 2800 - if {$opts(type) ne "" && $opts(type) ne [my @GetTypeInfoType $i]} { 2801 - continue; # Type does not match 2802 - } 2803 - if {$opts(name) ne "" && 2804 - [string compare -nocase $opts(name) [lindex [my @GetDocumentation $i -name] 1]]} { 2805 - continue; # Name does not match 2806 - } 2807 - set ti [my @GetTypeInfo $i] 2808 - if {$opts(guid) ne ""} { 2809 - if {[string compare -nocase [lindex [$ti @GetTypeAttr -guid] 1] $opts(guid)]} { 2810 - $ti Release 2811 - continue 2812 - } 2813 - } 2814 - set varti $ti 2815 - set ret [catch {uplevel 1 $script} result] 2816 - switch -exact -- $ret { 2817 - 1 { 2818 - error $result $::errorInfo $::errorCode 2819 - } 2820 - 2 { 2821 - return -code return $result; # TCL_RETURN 2822 - } 2823 - 3 { 2824 - set i $count; # TCL_BREAK 2825 - } 2826 - } 2827 - } 2828 - return 2829 - } 2830 - 2831 - method @Register {path {helppath ""}} { 2832 - my variable _ifc 2833 - ::twapi::RegisterTypeLib $_ifc $path $helppath 2834 - } 2835 - 2836 - method @LoadDispatchPrototypes {} { 2837 - set data [my @Read -type dispatch] 2838 - if {![dict exists $data dispatch]} { 2839 - return 2840 - } 2841 - 2842 - dict for {guid guiddata} [dict get $data dispatch] { 2843 - foreach type {methods properties} { 2844 - if {[dict exists $guiddata -$type]} { 2845 - dict for {name namedata} [dict get $guiddata -$type] { 2846 - dict for {lcid lciddata} $namedata { 2847 - dict for {invkind proto} $lciddata { 2848 - ::twapi::dispatch_prototype_set \ 2849 - $guid $name $lcid $invkind $proto 2850 - } 2851 - } 2852 - } 2853 - } 2854 - } 2855 - } 2856 - } 2857 - 2858 - method @Text {args} { 2859 - array set opts [::twapi::parseargs args { 2860 - type.arg 2861 - name.arg 2862 - } -maxleftover 0 -nulldefault] 2863 - 2864 - set text {} 2865 - my @Foreach -type $opts(type) -name $opts(name) ti { 2866 - ::twapi::trap { 2867 - array set attrs [$ti @GetTypeAttr -all] 2868 - set docs [$ti @GetDocumentation -1 -name -docstring] 2869 - set desc "[string totitle $attrs(-typekind)] [::twapi::kl_get $docs -name] $attrs(-guid) - [::twapi::kl_get $docs -docstring]\n" 2870 - switch -exact -- $attrs(-typekind) { 2871 - record - 2872 - union - 2873 - enum { 2874 - for {set j 0} {$j < $attrs(-varcount)} {incr j} { 2875 - array set vardata [$ti @GetVarDesc $j -all] 2876 - set vardesc "$vardata(-varkind) [::twapi::_resolve_com_type_text $ti $vardata(-datatype)] $vardata(-name)" 2877 - if {$attrs(-typekind) eq "enum"} { 2878 - append vardesc " = $vardata(-value) ([::twapi::_resolve_com_type_text $ti $vardata(-valuetype)])" 2879 - } else { 2880 - append vardesc " (offset $vardata(-value))" 2881 - } 2882 - append desc "\t$vardesc\n" 2883 - } 2884 - } 2885 - alias { 2886 - append desc "\ttypedef $attrs(-aliasdesc)\n" 2887 - } 2888 - module - 2889 - dispatch - 2890 - interface { 2891 - append desc [::twapi::_interface_text $ti] 2892 - } 2893 - coclass { 2894 - for {set j 0} {$j < $attrs(-interfacecount)} {incr j} { 2895 - set ti2 [$ti @GetRefTypeInfoFromIndex $j] 2896 - set idesc [$ti2 @GetName] 2897 - set iflags [$ti @GetImplTypeFlags $j] 2898 - if {[llength $iflags]} { 2899 - append idesc " ([join $iflags ,])" 2900 - } 2901 - append desc \t$idesc 2902 - $ti2 Release 2903 - unset ti2 2904 - } 2905 - } 2906 - default { 2907 - append desc "Unknown typekind: $attrs(-typekind)\n" 2908 - } 2909 - } 2910 - append text \n$desc 2911 - } finally { 2912 - $ti Release 2913 - if {[info exists ti2]} { 2914 - $ti2 Release 2915 - } 2916 - } 2917 - } 2918 - return $text 2919 - } 2920 - 2921 - method @GenerateCode {args} { 2922 - array set opts [twapi::parseargs args { 2923 - namespace.arg 2924 - } -ignoreunknown] 2925 - 2926 - if {![info exists opts(namespace)]} { 2927 - set opts(namespace) [string tolower [my @GetName]] 2928 - } 2929 - 2930 - set data [my @Read {*}$args] 2931 - 2932 - set code {} 2933 - if {[dict exists $data dispatch]} { 2934 - dict for {guid guiddata} [dict get $data dispatch] { 2935 - set dispatch_name [dict get $guiddata -name] 2936 - append code "\n# Dispatch Interface $dispatch_name\n" 2937 - foreach type {methods properties} { 2938 - if {[dict exists $guiddata -$type]} { 2939 - append code "# $dispatch_name [string totitle $type]\n" 2940 - dict for {name namedata} [dict get $guiddata -$type] { 2941 - dict for {lcid lciddata} $namedata { 2942 - dict for {invkind proto} $lciddata { 2943 - append code [list ::twapi::dispatch_prototype_set \ 2944 - $guid $name $lcid $invkind $proto] 2945 - append code \n 2946 - } 2947 - } 2948 - } 2949 - } 2950 - } 2951 - } 2952 - } 2953 - 2954 - # If namespace specfied as empty string (as opposed to unspecified) 2955 - # do not output a namespace 2956 - if {$opts(namespace) ne "" && 2957 - ([dict exists $data enum] || 2958 - [dict exists $data module] || 2959 - [dict exists $data coclass]) 2960 - } { 2961 - append code "\nnamespace eval $opts(namespace) \{" 2962 - append code \n 2963 - } 2964 - 2965 - if {[dict exists $data module]} { 2966 - dict for {guid guiddata} [dict get $data module] { 2967 - # Some modules may not have constants (-values). 2968 - # We currently only output constants from modules, not functions 2969 - if {[dict exists $guiddata -values]} { 2970 - set module_name [dict get $guiddata -name] 2971 - append code "\n # Module $module_name ($guid)\n" 2972 - append code " [list array set $module_name [dict get $guiddata -values]]" 2973 - append code \n 2974 - } 2975 - } 2976 - } 2977 - 2978 - if {[dict exists $data enum]} { 2979 - dict for {name def} [dict get $data enum] { 2980 - append code "\n # Enum $name\n" 2981 - append code " [list array set $name [dict get $def -values]]" 2982 - append code \n 2983 - } 2984 - } 2985 - 2986 - if {[dict exists $data coclass]} { 2987 - dict for {guid def} [dict get $data coclass] { 2988 - append code "\n # Coclass [dict get $def -name]" 2989 - # Look for the default interface so we can remember its GUID. 2990 - # This is necessary for the cases where the Dispatch interface 2991 - # GUID is not available via a TypeInfo interface (e.g. 2992 - # a 64-bit COM component not registered with the 32-bit 2993 - # COM registry) 2994 - set default_dispatch_guid "" 2995 - if {[dict exists $def -interfaces]} { 2996 - dict for {ifc_guid ifc_def} [dict get $def -interfaces] { 2997 - if {[dict exists $data dispatch $ifc_guid]} { 2998 - # Yes it is a dispatch interface 2999 - # Make sure it is marked as default interface 3000 - if {[dict exists $ifc_def -flags] && 3001 - [dict get $ifc_def -flags] == 1} { 3002 - set default_dispatch_guid $ifc_guid 3003 - break 3004 - } 3005 - } 3006 - } 3007 - } 3008 - 3009 - # We assume here that coclass has a default interface 3010 - # which is dispatchable. Else an error will be generated 3011 - # at runtime. 3012 - append code [format { 3013 - twapi::class create %1$s { 3014 - superclass ::twapi::Automation 3015 - constructor {args} { 3016 - set ifc [twapi::com_create_instance "%2$s" -interface IDispatch -raw {*}$args] 3017 - next [twapi::IDispatchProxy new $ifc "%2$s"] 3018 - if {[string length "%3$s"]} { 3019 - my -interfaceguid "%3$s" 3020 - } 3021 - } 3022 - }} [dict get $def -name] $guid $default_dispatch_guid] 3023 - append code \n 3024 - } 3025 - } 3026 - 3027 - if {$opts(namespace) ne "" && 3028 - ([dict exists $data enum] || 3029 - [dict exists $data module] || 3030 - [dict exists $data coclass]) 3031 - } { 3032 - append code "\}" 3033 - append code \n 3034 - } 3035 - 3036 - 3037 - return $code 3038 - } 3039 - 3040 - method @Read {args} { 3041 - array set opts [::twapi::parseargs args { 3042 - type.arg 3043 - name.arg 3044 - } -maxleftover 0 -nulldefault] 3045 - 3046 - set data [dict create] 3047 - my @Foreach -type $opts(type) -name $opts(name) ti { 3048 - ::twapi::trap { 3049 - array set attrs [$ti @GetTypeAttr -guid -lcid -varcount -fncount -interfacecount -typekind] 3050 - set name [lindex [$ti @GetDocumentation -1 -name] 1] 3051 - # dict set data $attrs(-typekind) $name {} 3052 - switch -exact -- $attrs(-typekind) { 3053 - record - 3054 - union - 3055 - enum { 3056 - # For consistency with the coclass and dispatch dict structure 3057 - # we have a separate key for 'name' even though it is the same 3058 - # as the dict key 3059 - dict set data $attrs(-typekind) $name -name $name 3060 - for {set j 0} {$j < $attrs(-varcount)} {incr j} { 3061 - array set vardata [$ti @GetVarDesc $j -name -value] 3062 - dict set data $attrs(-typekind) $name -values $vardata(-name) $vardata(-value) 3063 - } 3064 - } 3065 - alias { 3066 - # TBD - anything worth importing ? 3067 - } 3068 - dispatch { 3069 - # Load up the functions 3070 - dict set data $attrs(-typekind) $attrs(-guid) -name $name 3071 - for {set j 0} {$j < $attrs(-fncount)} {incr j} { 3072 - array set funcdata [$ti GetFuncDesc $j] 3073 - if {$funcdata(funckind) != 4} { 3074 - # Not a dispatch function (4), ignore 3075 - # TBD - what else could it be if already filtering 3076 - # typeinfo on dispatch 3077 - # Vtable set funckind "(vtable $funcdata(-oVft))" 3078 - ::twapi::debuglog "Unexpected funckind value '$funcdata(funckind)' ignored. funcdata: [array get funcdata]" 3079 - continue; 3080 - } 3081 - 3082 - set proto [list $funcdata(memid) \ 3083 - $attrs(-lcid) \ 3084 - $funcdata(invkind) \ 3085 - $funcdata(elemdescFunc.tdesc) \ 3086 - [::twapi::_resolve_params_for_prototype $ti $funcdata(lprgelemdescParam)]] 3087 - # Param names are needed for named arguments. Index 0 is method name so skip it 3088 - if {[catch {lappend proto [lrange [$ti GetNames $funcdata(memid)] 1 end]}]} { 3089 - # Could not get param names 3090 - lappend proto {} 3091 - } 3092 - 3093 - dict set data "$attrs(-typekind)" \ 3094 - $attrs(-guid) \ 3095 - -methods \ 3096 - [$ti @GetName $funcdata(memid)] \ 3097 - $attrs(-lcid) \ 3098 - $funcdata(invkind) \ 3099 - $proto 3100 - } 3101 - # Load up the properties 3102 - for {set j 0} {$j < $attrs(-varcount)} {incr j} { 3103 - array set vardata [$ti GetVarDesc $j] 3104 - # We will add both propput and propget. 3105 - # propget: 3106 - dict set data "$attrs(-typekind)" \ 3107 - $attrs(-guid) \ 3108 - -properties \ 3109 - [$ti @GetName $vardata(memid)] \ 3110 - $attrs(-lcid) \ 3111 - 2 \ 3112 - [list $vardata(memid) $attrs(-lcid) 2 $vardata(elemdescVar.tdesc) {} {}] 3113 - 3114 - # TBD - mock up the parameters for the property set 3115 - # Single parameter corresponding to return type of 3116 - # property. Param list is of the form 3117 - # {PARAM1 PARAM2} where PARAM is {TYPE {FLAGS ?DEFAULT}} 3118 - # So param list with one param is 3119 - # {{TYPE {FLAGS ?DEFAULT?}}} 3120 - # propput: 3121 - if {! ($vardata(wVarFlags) & 1)} { 3122 - # Not read-only 3123 - dict set data "$attrs(-typekind)" \ 3124 - $attrs(-guid) \ 3125 - -properties \ 3126 - [$ti @GetName $vardata(memid)] \ 3127 - $attrs(-lcid) \ 3128 - 4 \ 3129 - [list $vardata(memid) $attrs(-lcid) 4 24 [list [list $vardata(elemdescVar.tdesc) [list 1]]] {}] 3130 - } 3131 - } 3132 - } 3133 - 3134 - 3135 - module { 3136 - dict set data $attrs(-typekind) $attrs(-guid) -name $name 3137 - # TBD - Load up the functions 3138 - 3139 - # Now load up the variables 3140 - for {set j 0} {$j < $attrs(-varcount)} {incr j} { 3141 - array set vardata [$ti @GetVarDesc $j -name -value] 3142 - dict set data $attrs(-typekind) $attrs(-guid) -values $vardata(-name) $vardata(-value) 3143 - } 3144 - } 3145 - 3146 - interface { 3147 - # TBD 3148 - } 3149 - coclass { 3150 - dict set data "coclass" $attrs(-guid) -name $name 3151 - for {set j 0} {$j < $attrs(-interfacecount)} {incr j} { 3152 - set ti2 [$ti @GetRefTypeInfoFromIndex $j] 3153 - set iflags [$ti GetImplTypeFlags $j] 3154 - set iguid [twapi::kl_get [$ti2 GetTypeAttr] guid] 3155 - set iname [$ti2 @GetName] 3156 - $ti2 Release 3157 - unset ti2; # So finally clause does not relese again on error 3158 - 3159 - dict set data "coclass" $attrs(-guid) -interfaces $iguid -name $iname 3160 - dict set data "coclass" $attrs(-guid) -interfaces $iguid -flags $iflags 3161 - } 3162 - } 3163 - default { 3164 - # TBD 3165 - } 3166 - } 3167 - } finally { 3168 - $ti Release 3169 - if {[info exists ti2]} { 3170 - $ti2 Release 3171 - } 3172 - } 3173 - } 3174 - return $data 3175 - } 3176 - 3177 - twapi_exportall 3178 -} 3179 - 3180 -# ITypeComp 3181 -#---------- 3182 -twapi::class create ::twapi::ITypeCompProxy { 3183 - superclass ::twapi::IUnknownProxy 3184 - 3185 - method Bind {name lhash flags} { 3186 - my variable _ifc 3187 - return [::twapi::ITypeComp_Bind $_ifc $name $lhash $flags] 3188 - } 3189 - 3190 - # Returns empty list if bind not found 3191 - method @Bind {name flags {lcid 0}} { 3192 - ::twapi::trap { 3193 - set binding [my Bind $name [::twapi::LHashValOfName $lcid $name] $flags] 3194 - } onerror {TWAPI_WIN32 0x80028ca0} { 3195 - # Found but type mismatch (flags not correct) 3196 - return {} 3197 - } 3198 - 3199 - lassign $binding type data tifc 3200 - return [list $type $data [::twapi::make_interface_proxy $tifc]] 3201 - } 3202 - 3203 - twapi_exportall 3204 -} 3205 - 3206 -# IEnumVARIANT 3207 -#------------- 3208 - 3209 -twapi::class create ::twapi::IEnumVARIANTProxy { 3210 - superclass ::twapi::IUnknownProxy 3211 - 3212 - method Next {count {value_only 0}} { 3213 - my variable _ifc 3214 - return [::twapi::IEnumVARIANT_Next $_ifc $count $value_only] 3215 - } 3216 - method Clone {} { 3217 - my variable _ifc 3218 - return [::twapi::IEnumVARIANT_Clone $_ifc] 3219 - } 3220 - method @Clone {} { 3221 - return [::twapi::make_interface_proxy [my Clone]] 3222 - } 3223 - method Reset {} { 3224 - my variable _ifc 3225 - return [::twapi::IEnumVARIANT_Reset $_ifc] 3226 - } 3227 - method Skip {count} { 3228 - my variable _ifc 3229 - return [::twapi::IEnumVARIANT_Skip $_ifc $count] 3230 - } 3231 - 3232 - twapi_exportall 3233 -} 3234 - 3235 -# Automation 3236 -#----------- 3237 -twapi::class create ::twapi::Automation { 3238 - 3239 - # Caller gives up ownership of proxy in all cases, even errors. 3240 - # $proxy will eventually be Release'ed. If caller wants to keep 3241 - # a reference to it, it must do an *additional* AddRef on it to 3242 - # keep it from going away when the Automation object releases it. 3243 - constructor {proxy {lcid 0}} { 3244 - my variable _proxy _lcid _sinks _connection_pts 3245 - 3246 - set type [$proxy @Type] 3247 - if {$type ne "IDispatch" && $type ne "IDispatchEx"} { 3248 - $proxy Release; # Even on error, responsible for releasing 3249 - error "Automation objects do not support interfaces of type '$type'" 3250 - } 3251 - if {$type eq "IDispatchEx"} { 3252 - my variable _have_dispex 3253 - # If _have_dispex variable 3254 - # - does not exist, have not tried to get IDispatchEx yet 3255 - # - is 0, have tried but failed 3256 - # - is 1, already have IDispatchEx 3257 - set _have_dispex 1 3258 - } 3259 - 3260 - set _proxy $proxy 3261 - set _lcid $lcid 3262 - array set _sinks {} 3263 - array set _connection_pts {} 3264 - } 3265 - 3266 - destructor { 3267 - my variable _proxy _sinks 3268 - 3269 - # Release sinks, connection points 3270 - foreach sinkid [array names _sinks] { 3271 - my -unbind $sinkid 3272 - } 3273 - 3274 - if {[info exists _proxy]} { 3275 - $_proxy Release 3276 - } 3277 - return 3278 - } 3279 - 3280 - # Intended to be called only from another method. Not directly. 3281 - # Does an uplevel 2 to get to application context. 3282 - # On failures, retries with IDispatchEx interface 3283 - # TBD - get rid of this uplevel business by having internal 3284 - # callers to equivalent of "uplevel 1 my _invoke ... 3285 - method _invoke {name invkinds params args} { 3286 - my variable _proxy _lcid 3287 - 3288 - if {[$_proxy @Null?]} { 3289 - error "Attempt to invoke method $name on NULL COM object" 3290 - } 3291 - 3292 - array set opts [twapi::parseargs args { 3293 - raw.bool 3294 - namedargs.arg 3295 - } -nulldefault -maxleftover 0] 3296 - 3297 - ::twapi::trap { 3298 - set vtval [uplevel 2 [list $_proxy @Invoke $name $invkinds $_lcid $params $opts(namedargs)]] 3299 - if {$opts(raw)} { 3300 - return $vtval 3301 - } else { 3302 - return [::twapi::variant_value $vtval 0 0 $_lcid] 3303 - } 3304 - } onerror {} { 3305 - # TBD - should we only drop down below to check for IDispatchEx 3306 - # for specific error codes. Right now we do it for all. 3307 - set erinfo $::errorInfo 3308 - set ercode $::errorCode 3309 - set ermsg [::twapi::trapresult] 3310 - } 3311 - 3312 - # We plan on trying to get a IDispatchEx interface in case 3313 - # the method/property is the "expando" type 3314 - my variable _have_dispex 3315 - if {[info exists _have_dispex]} { 3316 - # We have already tried for IDispatchEx, either successfully 3317 - # or not. Either way, no need to try again 3318 - error $ermsg $erinfo $ercode 3319 - } 3320 - 3321 - # Try getting a IDispatchEx interface 3322 - if {[catch {$_proxy @QueryInterface IDispatchEx 1} proxy_ex] || 3323 - $proxy_ex eq ""} { 3324 - set _have_dispex 0 3325 - error $ermsg $erinfo $ercode 3326 - } 3327 - 3328 - set _have_dispex 1 3329 - $_proxy Release 3330 - set _proxy $proxy_ex 3331 - 3332 - # Retry with the IDispatchEx interface 3333 - set vtval [uplevel 2 [list $_proxy @Invoke $name $invkinds $_lcid $params $opts(namedargs)]] 3334 - if {$opts(raw)} { 3335 - return $vtval 3336 - } else { 3337 - return [::twapi::variant_value $vtval 0 0 $_lcid] 3338 - } 3339 - } 3340 - 3341 - method -get {name args} { 3342 - return [my _invoke $name [list 2] $args] 3343 - } 3344 - 3345 - method -set {name args} { 3346 - return [my _invoke $name [list 4] $args] 3347 - } 3348 - 3349 - method -call {name args} { 3350 - return [my _invoke $name [list 1] $args] 3351 - } 3352 - 3353 - method -callnamedargs {name args} { 3354 - return [my _invoke $name [list 1] {} -namedargs $args] 3355 - } 3356 - 3357 - # Need a wrapper around _invoke in order for latter's uplevel 2 3358 - # to work correctly 3359 - # TBD - document, test 3360 - method -invoke {name invkinds params args} { 3361 - return [my _invoke $name $invkinds $params {*}$args] 3362 - } 3363 - 3364 - method -destroy {} { 3365 - my destroy 3366 - } 3367 - 3368 - method -isnull {} { 3369 - my variable _proxy 3370 - return [$_proxy @Null?] 3371 - } 3372 - 3373 - method -default {} { 3374 - my variable _proxy _lcid 3375 - return [::twapi::variant_value [$_proxy Invoke ""] 0 0 $_lcid] 3376 - } 3377 - 3378 - # Caller must call release on the proxy 3379 - method -proxy {} { 3380 - my variable _proxy 3381 - $_proxy AddRef 3382 - return $_proxy 3383 - } 3384 - 3385 - # Only for debugging 3386 - method -proxyrefcounts {} { 3387 - my variable _proxy 3388 - return [$_proxy DebugRefCounts] 3389 - } 3390 - 3391 - # Returns the raw interface. Caller must call IUnknownRelease on it 3392 - # iff addref is passed as true (default) 3393 - method -interface {{addref 1}} { 3394 - my variable _proxy 3395 - return [$_proxy @Interface $addref] 3396 - } 3397 - 3398 - # Validates internal structures 3399 - method -validate {} { 3400 - twapi::ValidateIUnknown [my -interface 0] 3401 - } 3402 - 3403 - # Set/return the GUID for the interface 3404 - method -interfaceguid {{guid ""}} { 3405 - my variable _proxy 3406 - return [$_proxy @SetGuid $guid] 3407 - } 3408 - 3409 - # Return the disp id for a method/property 3410 - method -dispid {name} { 3411 - my variable _proxy 3412 - return [$_proxy @GetIDOfOneName $name] 3413 - } 3414 - 3415 - # Prints methods in an interface 3416 - method -print {} { 3417 - my variable _proxy 3418 - ::twapi::dispatch_print $_proxy 3419 - } 3420 - 3421 - method -with {subobjlist args} { 3422 - # $obj -with SUBOBJECTPATHLIST arguments 3423 - # where SUBOBJECTPATHLIST is list each element of which is 3424 - # either a property or a method of the previous element in 3425 - # the list. The element may itself be a list in which case 3426 - # the first element is the property/method and remaining 3427 - # are passed to it 3428 - # 3429 - # Note that 'arguments' may themselves be comobj subcommands! 3430 - set next [self] 3431 - set releaselist [list ] 3432 - ::twapi::trap { 3433 - while {[llength $subobjlist]} { 3434 - set nextargs [lindex $subobjlist 0] 3435 - set subobjlist [lrange $subobjlist 1 end] 3436 - set next [uplevel 1 [list $next] $nextargs] 3437 - lappend releaselist $next 3438 - } 3439 - # We use uplevel here because again we want to run in caller 3440 - # context 3441 - return [uplevel 1 [list $next] $args] 3442 - } finally { 3443 - foreach next $releaselist { 3444 - $next -destroy 3445 - } 3446 - } 3447 - } 3448 - 3449 - method -iterate {args} { 3450 - my variable _lcid 3451 - 3452 - array set opts [::twapi::parseargs args { 3453 - cleanup 3454 - }] 3455 - 3456 - if {[llength $args] < 2} { 3457 - error "Syntax: COMOBJ -iterate ?options? VARNAME SCRIPT" 3458 - } 3459 - upvar 1 [lindex $args 0] var 3460 - set script [lindex $args 1] 3461 - 3462 - # TBD - need more comprehensive test cases when return/break/continue 3463 - # are used in the script 3464 - 3465 - # First get IEnumVariant iterator using the _NewEnum method 3466 - # TBD - As per MS OLE Automation spec, it appears _NewEnum 3467 - # MUST have dispid -4. Can we use this information when 3468 - # this object does not have an associated interface guid or 3469 - # when no prototype is available ? 3470 - set enumerator [my -get _NewEnum] 3471 - # This gives us an IUnknown. 3472 - ::twapi::trap { 3473 - # Convert the IUnknown to IEnumVARIANT 3474 - set iter [$enumerator @QueryInterface IEnumVARIANT] 3475 - if {! [$iter @Null?]} { 3476 - set more 1 3477 - while {$more} { 3478 - # Get the next item from iterator 3479 - set next [$iter Next 1] 3480 - lassign $next more values 3481 - if {[llength $values]} { 3482 - set var [::twapi::variant_value [lindex $values 0] 0 0 $_lcid] 3483 - set ret [catch {uplevel 1 $script} msg options] 3484 - switch -exact -- $ret { 3485 - 0 - 3486 - 4 { 3487 - # Body executed successfully, or invoked continue 3488 - if {$opts(cleanup)} { 3489 - $var destroy 3490 - } 3491 - } 3492 - 3 { 3493 - if {$opts(cleanup)} { 3494 - $var destroy 3495 - } 3496 - set more 0; # TCL_BREAK 3497 - } 3498 - 1 - 3499 - 2 - 3500 - default { 3501 - if {$opts(cleanup)} { 3502 - $var destroy 3503 - } 3504 - dict incr options -level 3505 - return -options $options $msg 3506 - } 3507 - 3508 - } 3509 - } 3510 - } 3511 - } 3512 - } finally { 3513 - $enumerator Release 3514 - if {[info exists iter] && ![$iter @Null?]} { 3515 - $iter Release 3516 - } 3517 - } 3518 - return 3519 - } 3520 - 3521 - method -bind {script} { 3522 - my variable _proxy _sinks _connection_pts 3523 - 3524 - # Get the coclass typeinfo and locate the source interface 3525 - # within it and retrieve disp id mappings 3526 - ::twapi::trap { 3527 - set coti [$_proxy @GetCoClassTypeInfo] 3528 - 3529 - # $coti is the coclass information. Get dispids for the default 3530 - # source interface for events and its guid 3531 - set srcti [$coti @GetDefaultSourceTypeInfo] 3532 - array set srcinfo [$srcti @GetTypeAttr -memidmap -guid] 3533 - 3534 - # TBD - implement IConnectionPointContainerProxy 3535 - # Now we need to get the actual connection point itself 3536 - set container [$_proxy QueryInterface IConnectionPointContainer] 3537 - set connpt_ifc [::twapi::IConnectionPointContainer_FindConnectionPoint $container $srcinfo(-guid)] 3538 - 3539 - # Finally, create our sink object 3540 - # TBD - need to make sure Automation object is not deleted or 3541 - # should the callback itself check? 3542 - # TBD - what guid should we be passing? CLSID or IID ? 3543 - set sink_ifc [::twapi::Twapi_ComServer $srcinfo(-guid) $srcinfo(-memidmap) [list ::twapi::_eventsink_callback [self] $script]] 3544 - 3545 - # OK, we finally have everything we need. Tell the event source 3546 - set sinkid [::twapi::IConnectionPoint_Advise $connpt_ifc $sink_ifc] 3547 - 3548 - set _sinks($sinkid) $sink_ifc 3549 - set _connection_pts($sinkid) $connpt_ifc 3550 - return $sinkid 3551 - } onerror {} { 3552 - # These are released only on error as otherwise they have 3553 - # to be kept until unbind time 3554 - foreach ifc {connpt_ifc sink_ifc} { 3555 - if {[info exists $ifc] && [set $ifc] ne ""} { 3556 - ::twapi::IUnknown_Release [set $ifc] 3557 - } 3558 - } 3559 - twapi::rethrow 3560 - } finally { 3561 - # In all cases, release any interfaces we created 3562 - # Note connpt_ifc and sink_ifc are released at unbind time except 3563 - # on error 3564 - foreach obj {coti srcti} { 3565 - if {[info exists $obj]} { 3566 - [set $obj] Release 3567 - } 3568 - } 3569 - if {[info exists container]} { 3570 - ::twapi::IUnknown_Release $container 3571 - } 3572 - } 3573 - } 3574 - 3575 - method -unbind {sinkid} { 3576 - my variable _proxy _sinks _connection_pts 3577 - 3578 - if {[info exists _connection_pts($sinkid)]} { 3579 - ::twapi::IConnectionPoint_Unadvise $_connection_pts($sinkid) $sinkid 3580 - unset _connection_pts($sinkid) 3581 - } 3582 - 3583 - if {[info exists _sinks($sinkid)]} { 3584 - ::twapi::IUnknown_Release $_sinks($sinkid) 3585 - unset _sinks($sinkid) 3586 - } 3587 - return 3588 - } 3589 - 3590 - method -securityblanket {args} { 3591 - my variable _proxy 3592 - if {[llength $args]} { 3593 - $_proxy @SetSecurityBlanket [lindex $args 0] 3594 - return 3595 - } else { 3596 - return [$_proxy @GetSecurityBlanket] 3597 - } 3598 - } 3599 - 3600 - method -lcid {{lcid ""}} { 3601 - my variable _lcid 3602 - if {$lcid ne ""} { 3603 - if {![string is integer -strict $lcid]} { 3604 - error "Invalid LCID $lcid" 3605 - } 3606 - set _lcid $lcid 3607 - } 3608 - return $_lcid 3609 - } 3610 - 3611 - method unknown {name args} { 3612 - # Try to figure out whether it is a property or method 3613 - 3614 - # We have to figure out if it is a property get, property put 3615 - # or a method. We make a guess based on number of parameters. 3616 - # We specify an order to try based on this. The invoke will try 3617 - # all invocations in that order. 3618 - # TBD - what about propputref ? 3619 - set nargs [llength $args] 3620 - if {$nargs == 0} { 3621 - # No arguments, cannot be propput. Try propget and method 3622 - set invkinds [list 2 1] 3623 - } elseif {$nargs == 1} { 3624 - # One argument, likely propput, method, propget 3625 - set invkinds [list 4 1 2] 3626 - } else { 3627 - # Multiple arguments, likely method, propput, propget 3628 - set invkinds [list 1 4 2] 3629 - } 3630 - 3631 - # TBD - should this do an uplevel ? 3632 - return [my _invoke $name $invkinds $args] 3633 - } 3634 - 3635 - twapi_exportall 3636 -} 3637 - 3638 -# 3639 -# Singleton NULL comobj object. We want to override default destroy methods 3640 -# to prevent object from being destroyed. This is a backward compatibility 3641 -# hack and not fool proof since the command could just be renamed away. 3642 -twapi::class create twapi::NullAutomation { 3643 - superclass twapi::Automation 3644 - constructor {} { 3645 - next [twapi::make_interface_proxy {0 IDispatch}] 3646 - } 3647 - method -destroy {} { 3648 - # Silently ignore 3649 - } 3650 - method destroy {} { 3651 - # Silently ignore 3652 - } 3653 - twapi_exportall 3654 -} 3655 - 3656 -twapi::NullAutomation create twapi::comobj_null 3657 -# twapi::Automation create twapi::comobj_null [twapi::make_interface_proxy {0 IDispatch}] 3658 - 3659 -proc twapi::_comobj_cleanup {} { 3660 - foreach obj [comobj_instances] { 3661 - $obj destroy 3662 - } 3663 -} 3664 - 3665 -# In order for servers to release objects properly, the IUnknown interface 3666 -# must have the same security settings as were used in the object creation 3667 -# call. This is a helper for that. 3668 -proc twapi::_com_set_iunknown_proxy {ifc blanket} { 3669 - set iunk [Twapi_IUnknown_QueryInterface $ifc [_iid_iunknown] IUnknown] 3670 - trap { 3671 - CoSetProxyBlanket $iunk {*}$blanket 3672 - } finally { 3673 - IUnknown_Release $iunk 3674 - } 3675 -} 3676 - 3677 - 3678 -twapi::proc* twapi::_init_authnames {} { 3679 - variable _com_authsvc_to_name 3680 - variable _com_name_to_authsvc 3681 - variable _com_impersonation_to_name 3682 - variable _com_name_to_impersonation 3683 - variable _com_authlevel_to_name 3684 - variable _com_name_to_authlevel 3685 - 3686 - set _com_authsvc_to_name {0 none 9 negotiate 10 ntlm 14 schannel 16 kerberos 0xffffffff default} 3687 - set _com_name_to_authsvc [swapl $_com_authsvc_to_name] 3688 - set _com_name_to_impersonation {default 0 anonymous 1 identify 2 impersonate 3 delegate 4} 3689 - set _com_impersonation_to_name [swapl $_com_name_to_impersonation] 3690 - set _com_name_to_authlevel {default 0 none 1 connect 2 call 3 packet 4 packetintegrity 5 privacy 6} 3691 - set _com_authlevel_to_name [swapl $_com_name_to_authlevel] 3692 -} { 3693 -} 3694 - 3695 -twapi::proc* twapi::_com_authsvc_to_name {authsvc} { 3696 - _init_authnames 3697 -} { 3698 - variable _com_authsvc_to_name 3699 - return [dict* $_com_authsvc_to_name $authsvc] 3700 -} 3701 - 3702 -twapi::proc* twapi::_com_name_to_authsvc {name} { 3703 - _init_authnames 3704 -} { 3705 - variable _com_name_to_authsvc 3706 - if {[string is integer -strict $name]} { 3707 - return $name 3708 - } 3709 - return [dict! $_com_name_to_authsvc $name] 3710 -} 3711 - 3712 -twapi::proc* twapi::_com_authlevel_to_name {authlevel} { 3713 - _init_authnames 3714 -} { 3715 - variable _com_authlevel_to_name 3716 - return [dict* $_com_authlevel_to_name $authlevel] 3717 -} 3718 - 3719 -twapi::proc* twapi::_com_name_to_authlevel {name} { 3720 - _init_authnames 3721 -} { 3722 - variable _com_name_to_authlevel 3723 - if {[string is integer -strict $name]} { 3724 - return $name 3725 - } 3726 - return [dict! $_com_name_to_authlevel $name] 3727 -} 3728 - 3729 - 3730 -twapi::proc* twapi::_com_impersonation_to_name {imp} { 3731 - _init_authnames 3732 -} { 3733 - variable _com_impersonation_to_name 3734 - return [dict* $_com_impersonation_to_name $imp] 3735 -} 3736 - 3737 -twapi::proc* twapi::_com_name_to_impersonation {name} { 3738 - _init_authnames 3739 -} { 3740 - variable _com_name_to_impersonation 3741 - if {[string is integer -strict $name]} { 3742 - return $name 3743 - } 3744 - return [dict! $_com_name_to_impersonation $name] 3745 -} 3746 - 3747 -################################################################# 3748 -# COM server implementation 3749 -# WARNING: do not use any fancy TclOO features because it has to 3750 -# run under 8.5/metoo as well 3751 -# TBD - test scripts? 3752 - 3753 -twapi::class create twapi::ComFactory { 3754 - constructor {clsid member_map create_command_prefix} { 3755 - my variable _clsid _create_command_prefix _member_map _ifc 3756 - 3757 - set _clsid $clsid 3758 - set _member_map $member_map 3759 - set _create_command_prefix $create_command_prefix 3760 - 3761 - set _ifc [twapi::Twapi_ClassFactory $_clsid [list [self] _create_instance]] 3762 - } 3763 - 3764 - destructor { 3765 - # TBD - what happens if factory is destroyed while objects still 3766 - # exist ? 3767 - # App MUST explicitly destroy objects before exiting 3768 - my variable _class_registration_id 3769 - if {[info exists _class_registration_id]} { 3770 - twapi::CoRevokeClassObject $_class_registration_id 3771 - } 3772 - } 3773 - 3774 - # Called from Twapi_ClassFactory_CreateInstance to create a new object 3775 - # Should not be called from elsewhere 3776 - method _create_instance {iid} { 3777 - my variable _create_command_prefix _member_map 3778 - # Note [list {*}$foo] != $foo - consider when foo contains a ";" 3779 - set obj_prefix [uplevel #0 [list {*}$_create_command_prefix]] 3780 - twapi::trap { 3781 - # Since we are not holding on to this interface ourselves, 3782 - # we can pass it on without AddRef'ing it 3783 - return [twapi::Twapi_ComServer $iid $_member_map $obj_prefix] 3784 - } onerror {} { 3785 - $obj_prefix destroy 3786 - twapi::rethrow 3787 - } 3788 - } 3789 - 3790 - method register {args} { 3791 - my variable _clsid _create_command_prefix _member_map _ifc _class_registration_id 3792 - twapi::parseargs args { 3793 - {model.arg any} 3794 - } -setvars -maxleftover 0 3795 - set model_flags 0 3796 - foreach m $model { 3797 - switch -exact -- $m { 3798 - any {twapi::setbits model_flags 20} 3799 - localserver {twapi::setbits model_flags 4} 3800 - remoteserver {twapi::setbits model_flags 16} 3801 - default {twapi::badargs! "Invalid COM class model '$m'"} 3802 - } 3803 - } 3804 - 3805 - # 0x6 -> REGCLS_MULTI_SEPARATE | REGCLS_SUSPENDED 3806 - set _class_registration_id [twapi::CoRegisterClassObject $_clsid $_ifc $model_flags 0x6] 3807 - return 3808 - } 3809 - 3810 - export _create_instance 3811 -} 3812 - 3813 -proc twapi::comserver_factory {clsid member_map command_prefix {name {}}} { 3814 - if {$name ne ""} { 3815 - uplevel 1 [list [namespace current]::ComFactory create $name $clsid $member_map $command_prefix] 3816 - } else { 3817 - uplevel 1 [list [namespace current]::ComFactory new $clsid $member_map $command_prefix] 3818 - } 3819 -} 3820 - 3821 -proc twapi::start_factories {{cmd {}}} { 3822 - # TBD - what if no class objects ? 3823 - CoResumeClassObjects 3824 - 3825 - if {[llength $cmd]} { 3826 - # TBD - normalize $cmd so to run in right namespace etc. 3827 - trace add variable [namspace current]::com_shutdown_signal write $cmd 3828 - return 3829 - } 3830 - 3831 - # This is set from the C code when we are not serving up any 3832 - # COM objects (either event callbacks or com servers) 3833 - vwait [namespace current]::com_shutdown_signal 3834 -} 3835 - 3836 -proc twapi::suspend_factories {} { 3837 - CoSuspendClassObjects 3838 -} 3839 - 3840 -proc twapi::resume_factories {} { 3841 - CoResumeClassObjects 3842 -} 3843 - 3844 -proc twapi::install_coclass_script {progid clsid version script_path args} { 3845 - # Need to extract params so we can prefix script name 3846 - set saved_args $args 3847 - array set opts [parseargs args { 3848 - params.arg 3849 - } -ignoreunknown] 3850 - 3851 - set script_path [file normalize $script_path] 3852 - 3853 - # Try to locate the wish executable to run the component 3854 - if {[info commands wm] eq ""} { 3855 - set dir [file dirname [info nameofexecutable]] 3856 - set wishes [glob -nocomplain -directory $dir wish*.exe] 3857 - if {[llength $wishes] == 0} { 3858 - error "Could not locate wish program." 3859 - } 3860 - set wish [lindex $wishes 0] 3861 - } else { 3862 - # We are running wish already 3863 - set wish [info nameofexecutable] 3864 - } 3865 - 3866 - set exe_path [file nativename [file attributes $wish -shortname]] 3867 - 3868 - set params "\"$script_path\"" 3869 - if {[info exists opts(params)]} { 3870 - append params " $params" 3871 - } 3872 - return [install_coclass $progid $clsid $version $exe_path {*}$args -outproc -params $params] 3873 -} 3874 - 3875 -proc twapi::install_coclass {progid clsid version path args} { 3876 - array set opts [twapi::parseargs args { 3877 - {scope.arg user {user system}} 3878 - appid.arg 3879 - appname.arg 3880 - inproc 3881 - outproc 3882 - service 3883 - params.arg 3884 - name.arg 3885 - } -maxleftover 0] 3886 - 3887 - switch [tcl::mathop::+ $opts(inproc) $opts(outproc) $opts(service)] { 3888 - 0 { 3889 - # Need to figure out the type 3890 - switch [file extension $path] { 3891 - .exe { set opts(outproc) 1 } 3892 - .ocx - 3893 - .dll { set opts(inproc) 1 } 3894 - default { set opts(service) 1 } 3895 - } 3896 - } 3897 - 1 {} 3898 - default { 3899 - badargs! "Only one of -inproc, -outproc or -service may be specified" 3900 - } 3901 - } 3902 - 3903 - if {(! [string is integer -strict $version]) || $version <= 0} { 3904 - twapi::badargs! "Invalid version '$version'. Must be a positive integer" 3905 - } 3906 - if {![regexp {^[[:alpha:]][[:alnum:]]*\.[[:alpha:]][[:alnum:]]*$} $progid]} { 3907 - badargs! "Invalid PROGID syntax '$progid'" 3908 - } 3909 - set clsid [canonicalize_guid $clsid] 3910 - if {![info exists opts(appid)]} { 3911 - # This is what dcomcnfg and oleview do - default to the CLSID 3912 - set opts(appid) $clsid 3913 - } else { 3914 - set opts(appid) [canonicalize_guid $opts(appid)] 3915 - } 3916 - 3917 - if {$opts(scope) eq "user"} { 3918 - if {$opts(service)} { 3919 - twapi::badargs! "Option -service cannot be specified if -scope is \"user\"" 3920 - } 3921 - set regtop HKEY_CURRENT_USER 3922 - } else { 3923 - set regtop HKEY_LOCAL_MACHINE 3924 - } 3925 - 3926 - set progid_path "$regtop\\Software\\Classes\\$progid" 3927 - set clsid_path "$regtop\\Software\\Classes\\CLSID\\$clsid" 3928 - set appid_path "$regtop\\Software\\Classes\\AppID\\$opts(appid)" 3929 - 3930 - if {$opts(service)} { 3931 - # TBD 3932 - badargs! "Option -service is not implemented" 3933 - } elseif {$opts(outproc)} { 3934 - if {[info exists opts(params)]} { 3935 - registry set "$clsid_path\\LocalServer32" "" "\"[file nativename [file normalize $path]]\" $opts(params)" 3936 - } else { 3937 - registry set "$clsid_path\\LocalServer32" "" "\"[file nativename [file normalize $path]]\"" 3938 - } 3939 - # TBD - We do not quote path for ServerExecutable, should we ? 3940 - registry set "$clsid_path\\LocalServer32" "ServerExecutable" [file nativename [file normalize $path]] 3941 - } else { 3942 - # TBD - We do not quote path here either, should we ? 3943 - registry set "$clsid_path\\InprocServer32" "" [file nativename [file normalize $path]] 3944 - } 3945 - 3946 - registry set "$clsid_path\\ProgID" "" "$progid.$version" 3947 - registry set "$clsid_path\\VersionIndependentProgID" "" $progid 3948 - 3949 - # Set the registry under the progid and progid.version 3950 - registry set "$progid_path\\CLSID" "" $clsid 3951 - registry set "$progid_path\\CurVer" "" "$progid.$version" 3952 - if {[info exists opts(name)]} { 3953 - registry set $progid_path "" $opts(name) 3954 - } 3955 - 3956 - append progid_path ".$version" 3957 - registry set "$progid_path\\CLSID" "" $clsid 3958 - if {[info exists opts(name)]} { 3959 - registry set $progid_path "" $opts(name) 3960 - } 3961 - 3962 - registry set $clsid_path "AppID" $opts(appid) 3963 - registry set $appid_path; # Always create the key even if nothing below 3964 - if {[info exists opts(appname)]} { 3965 - registry set $appid_path "" $opts(appname) 3966 - } 3967 - 3968 - if {$opts(service)} { 3969 - registry set $appid_path "LocalService" $path 3970 - if {[info exists opts(params)]} { 3971 - registry set $appid_path "ServiceParameters" $opts(params) 3972 - } 3973 - } 3974 - 3975 - return 3976 -} 3977 - 3978 -proc twapi::uninstall_coclass {progid args} { 3979 - # Note "CLSID" itself is a valid ProgID (it has a CLSID key below it) 3980 - # Also we want to protect against horrible errors that blow away 3981 - # entire branches if progid is empty, wrong value, etc. 3982 - # So only work with keys of the form X.X 3983 - if {![regexp {^[[:alpha:]][[:alnum:]]*\.[[:alpha:]][[:alnum:]]*$} $progid]} { 3984 - badargs! "Invalid PROGID syntax '$progid'" 3985 - } 3986 - 3987 - # Do NOT want to delete the CLSID key by mistake. Note below checks 3988 - # will not protect against this since they will return a valid value 3989 - # if progid is "CLSID" since that has a CLSID key below it as well. 3990 - if {[string equal -nocase $progid CLSID]} { 3991 - badargs! "Attempt to delete protected key 'CLSID'" 3992 - } 3993 - 3994 - array set opts [twapi::parseargs args { 3995 - {scope.arg user {user system}} 3996 - keepappid 3997 - } -maxleftover 0] 3998 - 3999 - switch -exact -- $opts(scope) { 4000 - user { set regtop HKEY_CURRENT_USER } 4001 - system { set regtop HKEY_LOCAL_MACHINE } 4002 - default { 4003 - badargs! "Invalid class registration scope '$opts(scope)'. Must be 'user' or 'system'" 4004 - } 4005 - } 4006 - 4007 - if {0} { 4008 - # Do NOT use this. If running under elevated, it will ignore 4009 - # HKEY_CURRENT_USER. 4010 - set clsid [progid_to_clsid $progid]; # Also protects against bogus progids 4011 - } else { 4012 - set clsid [registry get "$regtop\\Software\\Classes\\$progid\\CLSID" ""] 4013 - } 4014 - 4015 - # Should not be empty at this point but do not want to delete the 4016 - # whole Classes tree in case progid or clsid are empty strings 4017 - # because of some bug! That would be an epic disaster so try and 4018 - # protect. 4019 - if {$clsid eq ""} { 4020 - badargs! "CLSID corresponding to PROGID '$progid' is empty" 4021 - } 4022 - 4023 - # See if we need to delete the linked current version 4024 - if {! [catch { 4025 - registry get "$regtop\\Software\\Classes\\$progid\\CurVer" "" 4026 - } curver]} { 4027 - if {[string match -nocase ${progid}.* $curver]} { 4028 - registry delete "$regtop\\Software\\Classes\\$curver" 4029 - } 4030 - } 4031 - 4032 - # See if we need to delete the APPID 4033 - if {! $opts(keepappid)} { 4034 - if {! [catch { 4035 - registry get "$regtop\\Software\\Classes\\CLSID\\$clsid" "AppID" 4036 - } appid]} { 4037 - # Validate it is a real GUID 4038 - if {![catch {canonicalize_guid $appid}]} { 4039 - registry delete "$regtop\\Software\\Classes\\AppID\\$appid" 4040 - } 4041 - } 4042 - } 4043 - 4044 - # Finally delete the keys and hope we have not trashed the system 4045 - registry delete "$regtop\\Software\\Classes\\CLSID\\$clsid" 4046 - registry delete "$regtop\\Software\\Classes\\$progid" 4047 - 4048 - return 4049 -} 4050 - 4051 -
Deleted winlibs/twapi/console.tcl.
1 -# 2 -# Copyright (c) 2004-2014, Ashok P. Nadkarni 3 -# All rights reserved. 4 -# 5 -# See the file LICENSE for license 6 - 7 -namespace eval twapi { 8 -} 9 - 10 -# Allocate a new console 11 -proc twapi::allocate_console {} { 12 - AllocConsole 13 -} 14 - 15 -# Free a console 16 -proc twapi::free_console {} { 17 - FreeConsole 18 -} 19 - 20 -# Get a console handle 21 -proc twapi::get_console_handle {type} { 22 - switch -exact -- $type { 23 - 0 - 24 - stdin { set fn "CONIN\$" } 25 - 1 - 26 - stdout - 27 - 2 - 28 - stderr { set fn "CONOUT\$" } 29 - default { 30 - error "Unknown console handle type '$type'" 31 - } 32 - } 33 - 34 - # 0xC0000000 -> GENERIC_READ | GENERIC_WRITE 35 - # 3 -> FILE_SHARE_READ | FILE_SHARE_WRITE 36 - # 3 -> OPEN_EXISTING 37 - return [CreateFile $fn \ 38 - 0xC0000000 \ 39 - 3 \ 40 - {{} 1} \ 41 - 3 \ 42 - 0 \ 43 - NULL] 44 -} 45 - 46 -# Get a console handle 47 -proc twapi::get_standard_handle {type} { 48 - switch -exact -- $type { 49 - 0 - 50 - -11 - 51 - stdin { set type -11 } 52 - 1 - 53 - -12 - 54 - stdout { set type -12 } 55 - 2 - 56 - -13 - 57 - stderr { set type -13 } 58 - default { 59 - error "Unknown console handle type '$type'" 60 - } 61 - } 62 - return [GetStdHandle $type] 63 -} 64 - 65 -# Set a console handle 66 -proc twapi::set_standard_handle {type handle} { 67 - switch -exact -- $type { 68 - 0 - 69 - -11 - 70 - stdin { set type -11 } 71 - 1 - 72 - -12 - 73 - stdout { set type -12 } 74 - 2 - 75 - -13 - 76 - stderr { set type -13 } 77 - default { 78 - error "Unknown console handle type '$type'" 79 - } 80 - } 81 - return [SetStdHandle $type $handle] 82 -} 83 - 84 -proc twapi::_console_output_attr_to_flags {attrs} { 85 - set flags 0 86 - foreach {attr bool} $attrs { 87 - if {$bool} { 88 - set flags [expr {$flags | [_console_output_attr $attr]}] 89 - } 90 - } 91 - return $flags 92 -} 93 - 94 -proc twapi::_flags_to_console_output_attr {flags} { 95 - # Check for multiple bit attributes first, in order 96 - set attrs {} 97 - foreach attr { 98 - -fgwhite -bgwhite -fggray -bggray 99 - -fgturquoise -bgturquoise -fgpurple -bgpurple -fgyellow -bgyellow 100 - -fgred -bgred -fggreen -bggreen -fgblue -bgblue 101 - -fgbright -bgbright 102 - } { 103 - if {($flags & [_console_output_attr $attr]) == [_console_output_attr $attr]} { 104 - lappend attrs $attr 1 105 - set flags [expr {$flags & ~ [_console_output_attr $attr]}] 106 - if {$flags == 0} { 107 - break 108 - } 109 - } 110 - } 111 - 112 - return $attrs 113 -} 114 - 115 - 116 -# Get the current mode settings for the console 117 -proc twapi::_get_console_input_mode {conh} { 118 - set mode [GetConsoleMode $conh] 119 - return [_bitmask_to_switches $mode [_console_input_mode_syms]] 120 -} 121 -interp alias {} twapi::get_console_input_mode {} twapi::_do_console_proc twapi::_get_console_input_mode stdin 122 - 123 -# Get the current mode settings for the console 124 -proc twapi::_get_console_output_mode {conh} { 125 - set mode [GetConsoleMode $conh] 126 - return [_bitmask_to_switches $mode [_console_output_mode_syms]] 127 -} 128 -interp alias {} twapi::get_console_output_mode {} twapi::_do_console_proc twapi::_get_console_output_mode stdout 129 - 130 -# Set console input mode 131 -proc twapi::_set_console_input_mode {conh args} { 132 - set mode [_switches_to_bitmask $args [_console_input_mode_syms]] 133 - # If insertmode or quickedit mode are set, make sure to set extended bit 134 - if {$mode & 0x60} { 135 - setbits mode 0x80; # ENABLE_EXTENDED_FLAGS 136 - } 137 - 138 - SetConsoleMode $conh $mode 139 -} 140 -interp alias {} twapi::set_console_input_mode {} twapi::_do_console_proc twapi::_set_console_input_mode stdin 141 - 142 -# Modify console input mode 143 -proc twapi::_modify_console_input_mode {conh args} { 144 - set prev [GetConsoleMode $conh] 145 - set mode [_switches_to_bitmask $args [_console_input_mode_syms] $prev] 146 - # If insertmode or quickedit mode are set, make sure to set extended bit 147 - if {$mode & 0x60} { 148 - setbits mode 0x80; # ENABLE_EXTENDED_FLAGS 149 - } 150 - 151 - SetConsoleMode $conh $mode 152 - # Returns the old modes 153 - return [_bitmask_to_switches $prev [_console_input_mode_syms]] 154 -} 155 -interp alias {} twapi::modify_console_input_mode {} twapi::_do_console_proc twapi::_modify_console_input_mode stdin 156 - 157 -# 158 -# Set console output mode 159 -proc twapi::_set_console_output_mode {conh args} { 160 - set mode [_switches_to_bitmask $args [_console_output_mode_syms]] 161 - 162 - SetConsoleMode $conh $mode 163 - 164 -} 165 -interp alias {} twapi::set_console_output_mode {} twapi::_do_console_proc twapi::_set_console_output_mode stdout 166 - 167 -# Set console output mode 168 -proc twapi::_modify_console_output_mode {conh args} { 169 - set prev [GetConsoleMode $conh] 170 - set mode [_switches_to_bitmask $args [_console_output_mode_syms] $prev] 171 - 172 - SetConsoleMode $conh $mode 173 - # Returns the old modes 174 - return [_bitmask_to_switches $prev [_console_output_mode_syms]] 175 -} 176 -interp alias {} twapi::modify_console_output_mode {} twapi::_do_console_proc twapi::_modify_console_output_mode stdout 177 - 178 - 179 -# Create and return a handle to a screen buffer 180 -proc twapi::create_console_screen_buffer {args} { 181 - array set opts [parseargs args { 182 - {inherit.bool 0} 183 - {mode.arg readwrite {read write readwrite}} 184 - {secd.arg ""} 185 - {share.arg readwrite {none read write readwrite}} 186 - } -maxleftover 0] 187 - 188 - switch -exact -- $opts(mode) { 189 - read { set mode [_access_rights_to_mask generic_read] } 190 - write { set mode [_access_rights_to_mask generic_write] } 191 - readwrite { 192 - set mode [_access_rights_to_mask {generic_read generic_write}] 193 - } 194 - } 195 - switch -exact -- $opts(share) { 196 - none { 197 - set share 0 198 - } 199 - read { 200 - set share 1 ;# FILE_SHARE_READ 201 - } 202 - write { 203 - set share 2 ;# FILE_SHARE_WRITE 204 - } 205 - readwrite { 206 - set share 3 207 - } 208 - } 209 - 210 - return [CreateConsoleScreenBuffer \ 211 - $mode \ 212 - $share \ 213 - [_make_secattr $opts(secd) $opts(inherit)] \ 214 - 1] 215 -} 216 - 217 -# Retrieve information about a console screen buffer 218 -proc twapi::_get_console_screen_buffer_info {conh args} { 219 - array set opts [parseargs args { 220 - all 221 - textattr 222 - cursorpos 223 - maxwindowsize 224 - size 225 - windowlocation 226 - windowpos 227 - windowsize 228 - } -maxleftover 0] 229 - 230 - lassign [GetConsoleScreenBufferInfo $conh] size cursorpos textattr windowlocation maxwindowsize 231 - 232 - set result [list ] 233 - foreach opt {size cursorpos maxwindowsize windowlocation} { 234 - if {$opts($opt) || $opts(all)} { 235 - lappend result -$opt [set $opt] 236 - } 237 - } 238 - 239 - if {$opts(windowpos) || $opts(all)} { 240 - lappend result -windowpos [lrange $windowlocation 0 1] 241 - } 242 - 243 - if {$opts(windowsize) || $opts(all)} { 244 - lassign $windowlocation left top right bot 245 - lappend result -windowsize [list [expr {$right-$left+1}] [expr {$bot-$top+1}]] 246 - } 247 - 248 - if {$opts(textattr) || $opts(all)} { 249 - lappend result -textattr [_flags_to_console_output_attr $textattr] 250 - } 251 - 252 - return $result 253 -} 254 -interp alias {} twapi::get_console_screen_buffer_info {} twapi::_do_console_proc twapi::_get_console_screen_buffer_info stdout 255 - 256 -# Set the cursor position 257 -proc twapi::_set_console_cursor_position {conh pos} { 258 - SetConsoleCursorPosition $conh $pos 259 -} 260 -interp alias {} twapi::set_console_cursor_position {} twapi::_do_console_proc twapi::_set_console_cursor_position stdout 261 - 262 -# Get the cursor position 263 -proc twapi::get_console_cursor_position {conh} { 264 - return [lindex [get_console_screen_buffer_info $conh -cursorpos] 1] 265 -} 266 - 267 -# Write the specified string to the console 268 -proc twapi::_console_write {conh s args} { 269 - # Note writes are always in raw mode, 270 - # TBD - support for scrolling 271 - # TBD - support for attributes 272 - 273 - array set opts [parseargs args { 274 - position.arg 275 - {newlinemode.arg column {line column}} 276 - {restoreposition.bool 0} 277 - } -maxleftover 0] 278 - 279 - # Get screen buffer info including cursor position 280 - array set csbi [get_console_screen_buffer_info $conh -cursorpos -size] 281 - 282 - # Get current console mode for later restoration 283 - # If console is in processed mode, set it to raw mode 284 - set oldmode [get_console_output_mode $conh] 285 - set processed_index [lsearch -exact $oldmode "processed"] 286 - if {$processed_index >= 0} { 287 - # Console was in processed mode. Set it to raw mode 288 - set newmode [lreplace $oldmode $processed_index $processed_index] 289 - set_console_output_mode $conh $newmode 290 - } 291 - 292 - trap { 293 - # x,y are starting position to write 294 - if {[info exists opts(position)]} { 295 - lassign [_parse_integer_pair $opts(position)] x y 296 - } else { 297 - # No position specified, get current cursor position 298 - lassign $csbi(-cursorpos) x y 299 - } 300 - 301 - set startx [expr {$opts(newlinemode) == "column" ? $x : 0}] 302 - 303 - # Get screen buffer limits 304 - lassign $csbi(-size) width height 305 - 306 - # Ensure line terminations are just \n 307 - set s [string map [list \r\n \n] $s] 308 - 309 - # Write out each line at ($x,$y) 310 - # Either \r or \n is considered a newline 311 - foreach line [split $s \r\n] { 312 - if {$y >= $height} break 313 - set_console_cursor_position $conh [list $x $y] 314 - if {$x < $width} { 315 - # Write the characters - do not write more than buffer width 316 - set num_chars [expr {$width-$x}] 317 - if {[string length $line] < $num_chars} { 318 - set num_chars [string length $line] 319 - } 320 - WriteConsole $conh $line $num_chars 321 - } 322 - 323 - 324 - # Calculate starting position of next line 325 - incr y 326 - set x $startx 327 - } 328 - 329 - } finally { 330 - # Restore cursor if requested 331 - if {$opts(restoreposition)} { 332 - set_console_cursor_position $conh $csbi(-cursorpos) 333 - } 334 - # Restore output mode if changed 335 - if {[info exists newmode]} { 336 - set_console_output_mode $conh $oldmode 337 - } 338 - } 339 - 340 - return 341 -} 342 -interp alias {} twapi::write_console {} twapi::_do_console_proc twapi::_console_write stdout 343 -interp alias {} twapi::console_write {} twapi::_do_console_proc twapi::_console_write stdout 344 - 345 -# Fill an area of the console with the specified attribute 346 -proc twapi::_fill_console {conh args} { 347 - array set opts [parseargs args { 348 - position.arg 349 - numlines.int 350 - numcols.int 351 - {mode.arg column {line column}} 352 - window.bool 353 - fillchar.arg 354 - } -ignoreunknown] 355 - 356 - # args will now contain attribute switches if any 357 - set attr [_console_output_attr_to_flags $args] 358 - 359 - # Get screen buffer info for window and size of buffer 360 - array set csbi [get_console_screen_buffer_info $conh -windowpos -windowsize -size] 361 - # Height and width of the console 362 - lassign $csbi(-size) conx cony 363 - 364 - # Figure out what area we want to fill 365 - # startx,starty are starting position to write 366 - # sizex, sizey are the number of rows/lines 367 - if {[info exists opts(window)]} { 368 - if {[info exists opts(numlines)] || [info exists opts(numcols)] 369 - || [info exists opts(position)]} { 370 - error "Option -window cannot be used togther with options -position, -numlines or -numcols" 371 - } 372 - lassign [_parse_integer_pair $csbi(-windowpos)] startx starty 373 - lassign [_parse_integer_pair $csbi(-windowsize)] sizex sizey 374 - } else { 375 - if {[info exists opts(position)]} { 376 - lassign [_parse_integer_pair $opts(position)] startx starty 377 - } else { 378 - set startx 0 379 - set starty 0 380 - } 381 - if {[info exists opts(numlines)]} { 382 - set sizey $opts(numlines) 383 - } else { 384 - set sizey $cony 385 - } 386 - if {[info exists opts(numcols)]} { 387 - set sizex $opts(numcols) 388 - } else { 389 - set sizex [expr {$conx - $startx}] 390 - } 391 - } 392 - 393 - set firstcol [expr {$opts(mode) == "column" ? $startx : 0}] 394 - 395 - # Fill attribute at ($x,$y) 396 - set x $startx 397 - set y $starty 398 - while {$y < $cony && $y < ($starty + $sizey)} { 399 - if {$x < $conx} { 400 - # Write the characters - do not write more than buffer width 401 - set max [expr {$conx-$x}] 402 - if {[info exists attr]} { 403 - FillConsoleOutputAttribute $conh $attr [expr {$sizex > $max ? $max : $sizex}] [list $x $y] 404 - } 405 - if {[info exists opts(fillchar)]} { 406 - FillConsoleOutputCharacter $conh $opts(fillchar) [expr {$sizex > $max ? $max : $sizex}] [list $x $y] 407 - } 408 - } 409 - 410 - # Calculate starting position of next line 411 - incr y 412 - set x $firstcol 413 - } 414 - 415 - return 416 -} 417 -interp alias {} twapi::fill_console {} twapi::_do_console_proc twapi::_fill_console stdout 418 - 419 -# Clear the console 420 -proc twapi::_clear_console {conh args} { 421 - # I support we could just call fill_console but this code was already 422 - # written and is faster 423 - array set opts [parseargs args { 424 - {fillchar.arg " "} 425 - {windowonly.bool 0} 426 - } -maxleftover 0] 427 - 428 - array set cinfo [get_console_screen_buffer_info $conh -size -windowpos -windowsize] 429 - lassign $cinfo(-size) width height 430 - if {$opts(windowonly)} { 431 - # Only clear portion visible in the window. We have to do this 432 - # line by line since we do not want to erase text scrolled off 433 - # the window either in the vertical or horizontal direction 434 - lassign $cinfo(-windowpos) x y 435 - lassign $cinfo(-windowsize) w h 436 - for {set i 0} {$i < $h} {incr i} { 437 - FillConsoleOutputCharacter \ 438 - $conh \ 439 - $opts(fillchar) \ 440 - $w \ 441 - [list $x [expr {$y+$i}]] 442 - } 443 - } else { 444 - FillConsoleOutputCharacter \ 445 - $conh \ 446 - $opts(fillchar) \ 447 - [expr {($width*$height) }] \ 448 - [list 0 0] 449 - } 450 - return 451 -} 452 -interp alias {} twapi::clear_console {} twapi::_do_console_proc twapi::_clear_console stdout 453 -# 454 -# Flush console input 455 -proc twapi::_flush_console_input {conh} { 456 - FlushConsoleInputBuffer $conh 457 -} 458 -interp alias {} twapi::flush_console_input {} twapi::_do_console_proc twapi::_flush_console_input stdin 459 - 460 -# Return number of pending console input events 461 -proc twapi::_get_console_pending_input_count {conh} { 462 - return [GetNumberOfConsoleInputEvents $conh] 463 -} 464 -interp alias {} twapi::get_console_pending_input_count {} twapi::_do_console_proc twapi::_get_console_pending_input_count stdin 465 - 466 -# Generate a console control event 467 -proc twapi::generate_console_control_event {event {procgrp 0}} { 468 - switch -exact -- $event { 469 - ctrl-c {set event 0} 470 - ctrl-break {set event 1} 471 - default {error "Invalid event definition '$event'"} 472 - } 473 - GenerateConsoleCtrlEvent $event $procgrp 474 -} 475 - 476 -# Get number of mouse buttons 477 -proc twapi::num_console_mouse_buttons {} { 478 - return [GetNumberOfConsoleMouseButtons] 479 -} 480 - 481 -# Get console title text 482 -proc twapi::get_console_title {} { 483 - return [GetConsoleTitle] 484 -} 485 - 486 -# Set console title text 487 -proc twapi::set_console_title {title} { 488 - return [SetConsoleTitle $title] 489 -} 490 - 491 -# Get the handle to the console window 492 -proc twapi::get_console_window {} { 493 - return [GetConsoleWindow] 494 -} 495 - 496 -# Get the largest console window size 497 -proc twapi::_get_console_window_maxsize {conh} { 498 - return [GetLargestConsoleWindowSize $conh] 499 -} 500 -interp alias {} twapi::get_console_window_maxsize {} twapi::_do_console_proc twapi::_get_console_window_maxsize stdout 501 - 502 -proc twapi::_set_console_active_screen_buffer {conh} { 503 - SetConsoleActiveScreenBuffer $conh 504 -} 505 -interp alias {} twapi::set_console_active_screen_buffer {} twapi::_do_console_proc twapi::_set_console_active_screen_buffer stdout 506 - 507 -# Set the size of the console screen buffer 508 -proc twapi::_set_console_screen_buffer_size {conh size} { 509 - SetConsoleScreenBufferSize $conh [_parse_integer_pair $size] 510 -} 511 -interp alias {} twapi::set_console_screen_buffer_size {} twapi::_do_console_proc twapi::_set_console_screen_buffer_size stdout 512 - 513 -# Set the default text attribute 514 -proc twapi::_set_console_default_attr {conh args} { 515 - SetConsoleTextAttribute $conh [_console_output_attr_to_flags $args] 516 -} 517 -interp alias {} twapi::set_console_default_attr {} twapi::_do_console_proc twapi::_set_console_default_attr stdout 518 - 519 -# Set the console window position 520 -proc twapi::_set_console_window_location {conh rect args} { 521 - array set opts [parseargs args { 522 - {absolute.bool true} 523 - } -maxleftover 0] 524 - 525 - SetConsoleWindowInfo $conh $opts(absolute) $rect 526 -} 527 -interp alias {} twapi::set_console_window_location {} twapi::_do_console_proc twapi::_set_console_window_location stdout 528 - 529 -proc twapi::get_console_window_location {conh} { 530 - return [lindex [get_console_screen_buffer_info $conh -windowlocation] 1] 531 -} 532 - 533 -# Get the console code page 534 -proc twapi::get_console_output_codepage {} { 535 - return [GetConsoleOutputCP] 536 -} 537 - 538 -# Set the console code page 539 -proc twapi::set_console_output_codepage {cp} { 540 - SetConsoleOutputCP $cp 541 -} 542 - 543 -# Get the console input code page 544 -proc twapi::get_console_input_codepage {} { 545 - return [GetConsoleCP] 546 -} 547 - 548 -# Set the console input code page 549 -proc twapi::set_console_input_codepage {cp} { 550 - SetConsoleCP $cp 551 -} 552 - 553 -# Read a line of input 554 -proc twapi::_console_read {conh args} { 555 - if {[llength $args]} { 556 - set oldmode [modify_console_input_mode $conh {*}$args] 557 - } 558 - trap { 559 - return [ReadConsole $conh 1024] 560 - } finally { 561 - if {[info exists oldmode]} { 562 - set_console_input_mode $conh {*}$oldmode 563 - } 564 - } 565 -} 566 -interp alias {} twapi::console_read {} twapi::_do_console_proc twapi::_console_read stdin 567 - 568 -proc twapi::_map_console_controlkeys {control} { 569 - return [_make_symbolic_bitmask $control { 570 - capslock 0x80 571 - enhanced 0x100 572 - leftalt 0x2 573 - leftctrl 0x8 574 - numlock 0x20 575 - rightalt 0x1 576 - rightctrl 4 577 - scrolllock 0x40 578 - shift 0x10 579 - } 0] 580 -} 581 - 582 -proc twapi::_console_read_input_records {conh args} { 583 - parseargs args { 584 - {count.int 1} 585 - peek 586 - } -setvars -maxleftover 0 587 - set recs {} 588 - if {$peek} { 589 - set input [PeekConsoleInput $conh $count] 590 - } else { 591 - set input [ReadConsoleInput $conh $count] 592 - } 593 - foreach rec $input { 594 - switch [format %d [lindex $rec 0]] { 595 - 1 { 596 - lassign [lindex $rec 1] keydown repeat keycode scancode char controlstate 597 - lappend recs \ 598 - [list key [list \ 599 - keystate [expr {$keydown ? "down" : "up"}] \ 600 - repeat $repeat keycode $keycode \ 601 - scancode $scancode char $char \ 602 - controls [_map_console_controlkeys $controlstate]]] 603 - } 604 - 2 { 605 - lassign [lindex $rec 1] position buttonstate controlstate flags 606 - set buttons {} 607 - if {[expr {$buttonstate & 0x1}]} {lappend buttons left} 608 - if {[expr {$buttonstate & 0x2}]} {lappend buttons right} 609 - if {[expr {$buttonstate & 0x4}]} {lappend buttons left2} 610 - if {[expr {$buttonstate & 0x8}]} {lappend buttons left3} 611 - if {[expr {$buttonstate & 0x10}]} {lappend buttons left4} 612 - if {$flags & 0x8} { 613 - set horizontalwheel [expr {$buttonstate >> 16}] 614 - } else { 615 - set horizontalwheel 0 616 - } 617 - if {$flags & 0x4} { 618 - set verticalwheel [expr {$buttonstate >> 16}] 619 - } else { 620 - set verticalwheel 0 621 - } 622 - lappend recs \ 623 - [list mouse [list \ 624 - position $position \ 625 - buttons $buttons \ 626 - controls [_map_console_controlkeys $controlstate] \ 627 - doubleclick [expr {$flags & 0x2}] \ 628 - horizontalwheel $horizontalwheel \ 629 - moved [expr {$flags & 0x1}] \ 630 - verticalwheel $verticalwheel]] 631 - } 632 - default { 633 - lappend recs [list \ 634 - [dict* {4 buffersize 8 menu 16 focus} [lindex $rec 0]] \ 635 - [lindex $rec 1]] 636 - } 637 - } 638 - } 639 - return $recs 640 -} 641 -interp alias {} twapi::console_read_input_records {} twapi::_do_console_proc twapi::_console_read_input_records stdin 642 - 643 -# Set up a console handler 644 -proc twapi::_console_ctrl_handler {ctrl} { 645 - variable _console_control_script 646 - if {[info exists _console_control_script]} { 647 - return [uplevel #0 [linsert $_console_control_script end $ctrl]] 648 - } 649 - return 0; # Not handled 650 -} 651 -proc twapi::set_console_control_handler {script} { 652 - variable _console_control_script 653 - if {[string length $script]} { 654 - if {![info exists _console_control_script]} { 655 - Twapi_ConsoleEventNotifier 1 656 - } 657 - set _console_control_script $script 658 - } else { 659 - if {[info exists _console_control_script]} { 660 - Twapi_ConsoleEventNotifier 0 661 - unset _console_control_script 662 - } 663 - } 664 -} 665 - 666 -# 667 -# Utilities 668 -# 669 - 670 -# Helper to call a proc after doing a stdin/stdout/stderr -> handle 671 -# mapping. The handle is closed after calling the proc. The first 672 -# arg in $args must be the console handle if $args is not an empty list 673 -proc twapi::_do_console_proc {proc default args} { 674 - if {[llength $args] == 0} { 675 - set args [list $default] 676 - } 677 - set conh [lindex $args 0] 678 - switch -exact -- [string tolower $conh] { 679 - stdin - 680 - stdout - 681 - stderr { 682 - set real_handle [get_console_handle $conh] 683 - trap { 684 - lset args 0 $real_handle 685 - return [uplevel 1 [list $proc] $args] 686 - } finally { 687 - CloseHandle $real_handle 688 - } 689 - } 690 - } 691 - 692 - return [uplevel 1 [list $proc] $args] 693 -} 694 - 695 -proc twapi::_console_input_mode_syms {} { 696 - return { 697 - -processedinput 0x0001 698 - -lineinput 0x0002 699 - -echoinput 0x0004 700 - -windowinput 0x0008 701 - -mouseinput 0x0010 702 - -insertmode 0x0020 703 - -quickeditmode 0x0040 704 - -extendedmode 0x0080 705 - -autoposition 0x0100 706 - } 707 -} 708 - 709 -proc twapi::_console_output_mode_syms {} { 710 - return { -processedoutput 1 -wrapoutput 2 } 711 -} 712 - 713 -twapi::proc* twapi::_console_output_attr {sym} { 714 - variable _console_output_attr_syms 715 - array set _console_output_attr_syms { 716 - -fgblue 1 717 - -fggreen 2 718 - -fgturquoise 3 719 - -fgred 4 720 - -fgpurple 5 721 - -fgyellow 6 722 - -fggray 7 723 - -fgbright 8 724 - -fgwhite 15 725 - -bgblue 16 726 - -bggreen 32 727 - -bgturquoise 48 728 - -bgred 64 729 - -bgpurple 80 730 - -bgyellow 96 731 - -bggray 112 732 - -bgbright 128 733 - -bgwhite 240 734 - } 735 -} { 736 - variable _console_output_attr_syms 737 - if {[info exists _console_output_attr_syms($sym)]} { 738 - return $_console_output_attr_syms($sym) 739 - } 740 - 741 - badargs! "Invalid console output attribute '$sym'" 3 742 -} 743 -
Deleted winlibs/twapi/crypto.tcl.
1 -# 2 -# Copyright (c) 2007-2014, Ashok P. Nadkarni 3 -# All rights reserved. 4 -# 5 -# See the file LICENSE for license 6 - 7 -namespace eval twapi {} 8 - 9 -### Data protection 10 - 11 -proc twapi::protect_data {data args} { 12 - 13 - # Not used because doesn't seem to have any effect 14 - # {promptonunprotect.bool 0 0x1} 15 - parseargs args { 16 - {description.arg ""} 17 - {localmachine.bool 0 0x4} 18 - {noui.bool 0 0x1} 19 - {audit.bool 0 0x10} 20 - {hwnd.arg NULL} 21 - prompt.arg 22 - } -setvars -maxleftover 0 23 - 24 - if {[info exists prompt]} { 25 - # 2 -> PROMPTONPROTECT 26 - set prompt [list 2 $hwnd $prompt] 27 - } else { 28 - set prompt {} 29 - } 30 - 31 - return [CryptProtectData $data $description "" "" $prompt [expr {$localmachine | $noui | $audit}]] 32 -} 33 - 34 -proc twapi::unprotect_data {data args} { 35 - # Do not seem to have any effect 36 - # {promptonunprotect.bool 0 0x1} 37 - # {promptonprotect.bool 0 0x2} 38 - parseargs args { 39 - {withdescription.bool 0} 40 - {noui.bool 0 0x1} 41 - {hwnd.arg NULL} 42 - prompt.arg 43 - } -setvars -maxleftover 0 44 - 45 - if {[info exists prompt]} { 46 - # 2 -> PROMPTONPROTECT 47 - set prompt [list 2 $hwnd $prompt] 48 - } else { 49 - set prompt {} 50 - } 51 - 52 - set data [CryptUnprotectData $data "" "" $prompt $noui] 53 - if {$withdescription} { 54 - return $data 55 - } else { 56 - return [lindex $data 0] 57 - } 58 -} 59 - 60 - 61 - 62 -################################################################ 63 -# Certificate Stores 64 - 65 -# Close a certificate store 66 -proc twapi::cert_store_release {hstore} { 67 - CertCloseStore $hstore 0 68 - return 69 -} 70 - 71 -proc twapi::cert_temporary_store {args} { 72 - parseargs args { 73 - {encoding.arg der {der cer crt pem base64}} 74 - serialized.arg 75 - pkcs7.arg 76 - {password.arg ""} 77 - pfx.arg 78 - pkcs12.arg 79 - {exportableprivatekeys.bool 0 1} 80 - {userprotected.bool 0 2} 81 - keysettype.arg 82 - } -setvars -maxleftover 0 83 - 84 - set nformats 0 85 - foreach format {serialized pkcs7 pfx pkcs12} { 86 - if {[info exists $format]} { 87 - set data [set $format] 88 - incr nformats 89 - } 90 - } 91 - if {$nformats > 1} { 92 - badargs! "At most one of -pfx, -pkcs12, -pkcs7 or -serialized may be specified." 93 - } 94 - if {$nformats == 0} { 95 - # 2 -> CERT_STORE_PROV_MEMORY 96 - return [CertOpenStore 2 0 NULL 0 ""] 97 - } 98 - 99 - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING 100 - 101 - if {[info exists serialized]} { 102 - # 6 -> CERT_STORE_PROV_SERIALIZED 103 - return [CertOpenStore 6 0x10001 NULL 0 $data] 104 - } 105 - 106 - if {[info exists pkcs7]} { 107 - if {$encoding in {pem base64}} { 108 - # 6 -> CRYPT_STRING_BASE64_ANY 109 - set data [CryptStringToBinary $data 6] 110 - } 111 - # 5 -> CERT_STORE_PROV_PKCS7 112 - return [CertOpenStore 5 0x10001 NULL 0 $data] 113 - } 114 - 115 - # PFX/PKCS12 116 - if {[string length $password] == 0} { 117 - set password [conceal ""] 118 - } 119 - set flags 0 120 - if {[info exists keysettype]} { 121 - set flags [dict! {user 0x1000 machine 0x20} $keysettype] 122 - } 123 - 124 - set flags [tcl::mathop::| $flags $exportableprivatekeys $userprotected] 125 - return [PFXImportCertStore $data $password $flags] 126 -} 127 - 128 -proc twapi::cert_file_store_open {path args} { 129 - set flags [_parse_store_open_opts $args] 130 - 131 - if {! ($flags & 0x00008000)} { 132 - # If not readonly, set commitenable 133 - set flags [expr {$flags | 0x00010000}] 134 - } 135 - 136 - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING 137 - # 8 -> CERT_STORE_PROV_FILENAME_W 138 - return [CertOpenStore 8 0x10001 NULL $flags [file nativename [file normalize $path]]] 139 -} 140 - 141 -proc twapi::cert_serialized_store_open {data args} { 142 - set flags [_parse_store_open_opts $args] 143 - 144 - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING 145 - # 6 -> CERT_STORE_PROV_SERIALIZED 146 - return [CertOpenStore 6 0x10001 NULL $flags $data] 147 -} 148 - 149 - 150 - 151 -proc twapi::cert_physical_store_open {name location args} { 152 - variable _system_stores 153 - 154 - set flags [_parse_store_open_opts $args] 155 - incr flags [_system_store_id $location] 156 - # 14 -> CERT_STORE_PROV_PHYSICAL_W 157 - return [CertOpenStore 14 0 NULL $flags $name] 158 -} 159 - 160 -proc twapi::cert_physical_store_delete {name location} { 161 - set flags 0x10; # CERT_STORE_DELETE_FLAG 162 - incr flags [_system_store_id $location] 163 - 164 - # 14 -> CERT_STORE_PROV_PHYSICAL_W 165 - return [CertOpenStore 14 0 NULL $flags $name] 166 -} 167 - 168 -# TBD - document and figure out what format to return data in 169 -proc twapi::cert_physical_stores {system_store_name location} { 170 - return [CertEnumPhysicalStore $system_store_name [_system_store_id $location]] 171 -} 172 - 173 -proc twapi::cert_system_store_open {name args} { 174 - variable _system_stores 175 - 176 - if {[llength $args] == 0} { 177 - return [CertOpenSystemStore $name] 178 - } 179 - 180 - set flags [_parse_store_open_opts [lassign $args location]] 181 - incr flags [_system_store_id $location] 182 - return [CertOpenStore 10 0 NULL $flags $name] 183 -} 184 - 185 -proc twapi::cert_system_store_delete {name location} { 186 - set flags 0x10; # CERT_STORE_DELETE_FLAG 187 - incr flags [_system_store_id $location] 188 - return [CertOpenStore 10 0 NULL $flags $name] 189 -} 190 - 191 -proc twapi::cert_system_store_locations {} { 192 - set l {} 193 - foreach e [CertEnumSystemStoreLocation 0] { 194 - lappend l [lindex $e 0] 195 - } 196 - return $l 197 -} 198 - 199 -proc twapi::cert_system_stores {location} { 200 - set l {} 201 - foreach e [CertEnumSystemStore [_system_store_id $location] ""] { 202 - lappend l [lindex $e 0] 203 - } 204 - return $l 205 -} 206 - 207 -# TBD - document? 208 -proc twapi::cert_store_iterate {hstore varname script {type any} {term {}}} { 209 - upvar 1 $varname cert 210 - set cert NULL 211 - while {1} { 212 - set cert [cert_store_find_certificate $hstore $type $term $cert] 213 - if {$cert eq ""} break 214 - switch [catch {uplevel 1 $script} result options] { 215 - 0 - 216 - 4 {} 217 - 3 { 218 - cert_release $cert 219 - set cert "" 220 - return 221 - } 222 - 1 - 223 - default { 224 - cert_release $cert 225 - set cert "" 226 - return -options $options $result 227 - } 228 - } 229 - } 230 - return 231 -} 232 - 233 -proc twapi::cert_store_find_certificate {hstore {type any} {term {}} {hcert NULL}} { 234 - 235 - # TBD subject_cert 11<<16 236 - # TBD key_spec 9<<16 237 - 238 - set term_types { 239 - any 0 240 - existing 13<<16 241 - key_identifier 15<<16 242 - md5_hash 4<<16 243 - subject_public_key_md5_hash 18<<16 244 - sha1_hash 1<<16 245 - signature_hash 14<<16 246 - issuer_name (2<<16)|4 247 - subject_name (2<<16)|7 248 - issuer_substring (8<<16)|4 249 - subject_substring (8<<16)|7 250 - property 5<<16 251 - public_key 6<<16 252 - } 253 - 254 - if {$type eq "property"} { 255 - set term [_cert_prop_id $term] 256 - } 257 - set type [expr [dict! $term_types $type 1]] 258 - 259 - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING 260 - return [CertFindCertificateInStore $hstore 0x10001 0 $type $term $hcert] 261 -} 262 - 263 -proc twapi::cert_store_enum_contents {hstore {hcert NULL}} { 264 - return [CertEnumCertificatesInStore $hstore $hcert] 265 -} 266 - 267 -proc twapi::cert_store_add_certificate {hstore hcert args} { 268 - array set opts [_cert_add_parseargs args] 269 - return [CertAddCertificateContextToStore $hstore $hcert $opts(disposition)] 270 -} 271 - 272 -proc twapi::cert_store_add_encoded_certificate {hstore enccert args} { 273 - parseargs args { 274 - {encoding.arg der {der pem}} 275 - } -ignoreunknown -setvars 276 - array set opts [_cert_add_parseargs args] 277 - if {$encoding eq "pem"} { 278 - # 6 -> CRYPT_STRING_BASE64_ANY 279 - set enccert [CryptStringToBinary $enccert 6] 280 - } 281 - return [CertAddEncodedCertificateToStore $hstore 0x10001 $enccert $opts(disposition)] 282 -} 283 - 284 -proc twapi::cert_store_export_pfx {hstore password args} { 285 - parseargs args { 286 - {exportprivatekeys.bool 0 0x4} 287 - {failonmissingkey.bool 0 0x1} 288 - {failonunexportablekey.bool 0 0x2} 289 - } -maxleftover 0 -setvars 290 - 291 - if {[string length $password] == 0} { 292 - set password [conceal ""] 293 - } 294 - 295 - # NOTE: the -fail* flags only take effect iff the certificate in the store 296 - # claims to have a private key but does not actually have one. It will 297 - # not fail if the cert does not actually claim to have a private key 298 - 299 - set flags [tcl::mathop::| $exportprivatekeys $failonunexportablekey $failonmissingkey] 300 - 301 - return [PFXExportCertStoreEx $hstore $password {} $flags] 302 -} 303 -interp alias {} twapi::cert_store_export_pkcs12 {} twapi::cert_store_export_pfx 304 - 305 -proc twapi::cert_store_commit {hstore args} { 306 - array set opts [parseargs args { 307 - {force.bool 0} 308 - } -maxleftover 0] 309 - 310 - return [Twapi_CertStoreCommit $hstore $opts(force)] 311 -} 312 - 313 -proc twapi::cert_store_serialize {hstore} { 314 - return [Twapi_CertStoreSerialize $hstore 1] 315 -} 316 - 317 -proc twapi::cert_store_export_pkcs7 {hstore args} { 318 - parseargs args { 319 - {encoding.arg der {der pem}} 320 - } -setvars -maxleftover 0 321 - 322 - set exp [Twapi_CertStoreSerialize $hstore 2] 323 - if {$encoding eq "pem"} { 324 - # 1 -> CRYPT_STRING_BASE64 325 - # 0x80000000 -> LF-only, not CRLF 326 - return "-----BEGIN PKCS7-----\n[CryptBinaryToString $exp 0x80000001]-----END PKCS7-----\n" 327 - } else { 328 - return $exp 329 - } 330 -} 331 - 332 -################################################################ 333 -# Certificates 334 - 335 -interp alias {} twapi::cert_subject_name {} twapi::_cert_get_name subject 336 -interp alias {} twapi::cert_issuer_name {} twapi::_cert_get_name issuer 337 -proc twapi::_cert_get_name {field hcert args} { 338 - 339 - switch $field { 340 - subject { set field 0 } 341 - issuer { set field 1 } 342 - default { badargs! "Invalid name type '$field': must be \"subject\" or \"issuer\"." 343 - } 344 - } 345 - array set opts [parseargs args { 346 - {name.arg oid_common_name} 347 - {separator.arg comma {comma semicolon newline}} 348 - {reverse.bool 0 0x02000000} 349 - {noquote.bool 0 0x10000000} 350 - {noplus.bool 0 0x20000000} 351 - {format.arg x500 {x500 oid simple}} 352 - } -maxleftover 0] 353 - 354 - set arg "" 355 - switch $opts(name) { 356 - email { set what 1 } 357 - simpledisplay { set what 4 } 358 - friendlydisplay {set what 5 } 359 - dns { set what 6 } 360 - url { set what 7 } 361 - upn { set what 8 } 362 - rdn { 363 - set what 2 364 - switch $opts(format) { 365 - simple {set arg 1} 366 - oid {set arg 2} 367 - x500 - 368 - default {set arg 3} 369 - } 370 - set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}] 371 - switch $opts(separator) { 372 - semicolon { set arg [expr {$arg | 0x40000000}] } 373 - newline { set arg [expr {$arg | 0x08000000}] } 374 - } 375 - } 376 - default { 377 - set what 3; # Assume OID 378 - set arg [oid $opts(name)] 379 - } 380 - } 381 - 382 - return [CertGetNameString $hcert $what $field $arg] 383 - 384 -} 385 - 386 -proc twapi::cert_blob_to_name {blob args} { 387 - array set opts [parseargs args { 388 - {format.arg x500 {x500 oid simple}} 389 - {separator.arg comma {comma semi newline}} 390 - {reverse.bool 0 0x02000000} 391 - {noquote.bool 0 0x10000000} 392 - {noplus.bool 0 0x20000000} 393 - } -maxleftover 0] 394 - 395 - switch $opts(format) { 396 - x500 {set arg 3} 397 - simple {set arg 1} 398 - oid {set arg 2} 399 - } 400 - 401 - set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}] 402 - switch $opts(separator) { 403 - semi { set arg [expr {$arg | 0x40000000}] } 404 - newline { set arg [expr {$arg | 0x08000000}] } 405 - } 406 - 407 - return [CertNameToStr $blob $arg] 408 -} 409 - 410 -proc twapi::cert_name_to_blob {name args} { 411 - array set opts [parseargs args { 412 - {format.arg x500 {x500 oid simple}} 413 - {separator.arg any {any comma semicolon newline}} 414 - {reverse.bool 0 0x02000000} 415 - {noquote.bool 0 0x10000000} 416 - {noplus.bool 0 0x20000000} 417 - } -maxleftover 0] 418 - 419 - switch $opts(format) { 420 - x500 {set arg 3} 421 - simple {set arg 1} 422 - oid {set arg 2} 423 - } 424 - 425 - set arg [expr {$arg | $opts(reverse) | $opts(noquote) | $opts(noplus)}] 426 - switch $opts(separator) { 427 - comma { set arg [expr {$arg | 0x04000000}] } 428 - semicolon { set arg [expr {$arg | 0x40000000}] } 429 - newline { set arg [expr {$arg | 0x08000000}] } 430 - } 431 - 432 - return [CertStrToName $name $arg] 433 -} 434 - 435 -proc twapi::cert_enum_properties {hcert args} { 436 - parseargs args { 437 - names 438 - } -setvars -maxleftover 0 439 - 440 - set id 0 441 - set ids {} 442 - while {[set id [CertEnumCertificateContextProperties $hcert $id]]} { 443 - if {$names} { 444 - lappend ids [_cert_prop_name $id] 445 - } else { 446 - lappend ids $id 447 - } 448 - } 449 - return $ids 450 -} 451 - 452 -proc twapi::cert_property {hcert prop} { 453 - # TBD - need to cook some properties - enhkey_usage 454 - 455 - if {[string is integer -strict $prop]} { 456 - return [CertGetCertificateContextProperty $hcert $prop] 457 - } else { 458 - return [CertGetCertificateContextProperty $hcert [_cert_prop_id $prop] 1] 459 - } 460 -} 461 - 462 -proc twapi::cert_property_set {hcert prop propval} { 463 - switch $prop { 464 - pvk_file - 465 - friendly_name - 466 - description { 467 - set val [encoding convertto unicode "${propval}\0"] 468 - } 469 - enhkey_usage { 470 - set val [::twapi::CryptEncodeObjectEx 2.5.29.37 [_get_enhkey_usage_oids $propval]] 471 - } 472 - default { 473 - badargs! "Invalid or unsupported property name \"$prop\". Must be one of [join $unicode_props {, }]." 474 - } 475 - } 476 - 477 - CertSetCertificateContextProperty $hcert [_cert_prop_id $prop] 0 $val 478 -} 479 - 480 -proc twapi::cert_property_delete {hcert prop} { 481 - CertSetCertificateContextProperty $hcert [_cert_prop_id $prop] 0 482 -} 483 - 484 -# TBD - Also add cert_set_key_prov_from_crypt_context 485 -proc twapi::cert_set_key_prov {hcert args} { 486 - # TB - make keycontainer explicit arg 487 - parseargs args { 488 - keycontainer.arg 489 - csp.arg 490 - {csptype.arg prov_rsa_full} 491 - {keysettype.arg user {user machine}} 492 - {silent.bool 0 0x40} 493 - {keyspec.arg signature {keyexchange signature}} 494 - } -maxleftover 0 -nulldefault -setvars 495 - 496 - set flags $silent 497 - if {$keysettype eq "machine"} { 498 - incr flags 0x20; # CRYPT_KEYSET_MACHINE 499 - } 500 - 501 - # TBD - does the keyspec matter ? In case of self signed cert 502 - # which (keyexchange/signature) or both have to be specified ? 503 - 504 - # 2 -> CERT_KEY_PROV_INFO_PROP_ID 505 - # TBD - the provider param is hardcoded as {}. Should that be an option ? 506 - CertSetCertificateContextProperty $hcert 2 0 \ 507 - [list $keycontainer $csp [_csp_type_name_to_id $csptype] $flags {} [_crypt_keyspec $keyspec]] 508 - return 509 -} 510 - 511 -proc twapi::cert_export {hcert args} { 512 - parseargs args { 513 - {encoding.arg der {der pem}} 514 - } -maxleftover 0 -setvars 515 - 516 - set enc [lindex [Twapi_CertGetEncoded $hcert] 1] 517 - if {$encoding eq "pem"} { 518 - # 0 -> CRYPT_STRING_BASE64HEADER 519 - # 0x80000000 -> LF-only, not CRLF 520 - return [CryptBinaryToString $enc 0x80000000] 521 - } else { 522 - return $enc 523 - } 524 -} 525 - 526 -proc twapi::cert_import {enccert args} { 527 - parseargs args { 528 - {encoding.arg der {der pem}} 529 - } -maxleftover 0 -setvars 530 - 531 - if {$encoding eq "pem"} { 532 - # 6 -> CRYPT_STRING_BASE64_ANY 533 - set enccert [CryptStringToBinary $enccert 6] 534 - } 535 - 536 - return [CertCreateCertificateContext 0x10001 $enccert] 537 -} 538 - 539 - 540 -proc twapi::cert_enhkey_usage {hcert {loc both}} { 541 - return [_cert_decode_enhkey [CertGetEnhancedKeyUsage $hcert [dict! {property 4 extension 2 both 0} $loc 1]]] 542 -} 543 - 544 -proc twapi::cert_key_usage {hcert} { 545 - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING 546 - return [_cert_decode_keyusage [Twapi_CertGetIntendedKeyUsage 0x10001 $hcert]] 547 -} 548 - 549 -proc twapi::cert_thumbprint {hcert} { 550 - binary scan [cert_property $hcert sha1_hash] H* hash 551 - return $hash 552 -} 553 - 554 -proc twapi::cert_info {hcert} { 555 - return [twine { 556 - -version -serialnumber -signaturealgorithm -issuer 557 - -start -end -subject -publickey -issuerid -subjectid -extensions} \ 558 - [Twapi_CertGetInfo $hcert]] 559 -} 560 - 561 -proc twapi::cert_extension {hcert oid} { 562 - set ext [CertFindExtension $hcert [oid $oid]] 563 - if {[llength $ext] == 0} { 564 - return $ext 565 - } 566 - lassign $ext oid critical val 567 - return [list $critical [_cert_decode_extension $oid $val]] 568 -} 569 - 570 -proc twapi::cert_create_self_signed {subject args} { 571 - set args [_cert_create_parse_options $args opts] 572 - 573 - # TBD - make keycontainer explicit arg 574 - array set opts [parseargs args { 575 - {keyspec.arg signature {keyexchange signature}} 576 - {keycontainer.arg {}} 577 - {keysettype.arg user {machine user}} 578 - {silent.bool 0 0x40} 579 - {csp.arg {}} 580 - {csptype.arg {prov_rsa_full}} 581 - {signaturealgorithm.arg {}} 582 - } -maxleftover 0 -ignoreunknown] 583 - 584 - set name_blob [cert_name_to_blob $subject] 585 - 586 - set kiflags $opts(silent) 587 - if {$opts(keysettype) eq "machine"} { 588 - incr kiflags 0x20; # CRYPT_MACHINE_KEYSET 589 - } 590 - set keyinfo [list \ 591 - $opts(keycontainer) \ 592 - $opts(csp) \ 593 - [_csp_type_name_to_id $opts(csptype)] \ 594 - $kiflags \ 595 - {} \ 596 - [_crypt_keyspec $opts(keyspec)]] 597 - 598 - set flags 0; # Always 0 for now 599 - return [CertCreateSelfSignCertificate NULL $name_blob $flags $keyinfo \ 600 - [_make_algorithm_identifier $opts(signaturealgorithm)] \ 601 - $opts(start) $opts(end) $opts(extensions)] 602 -} 603 - 604 -proc twapi::cert_create_self_signed_from_crypt_context {subject hprov args} { 605 - set args [_cert_create_parse_options $args opts] 606 - 607 - array set opts [parseargs args { 608 - {signaturealgorithm.arg {}} 609 - } -maxleftover 0] 610 - 611 - set name_blob [cert_name_to_blob $subject] 612 - 613 - set flags 0; # Always 0 for now 614 - return [CertCreateSelfSignCertificate $hprov $name_blob $flags {} \ 615 - [_make_algorithm_identifier $opts(signaturealgorithm)] \ 616 - $opts(start) $opts(end) $opts(extensions)] 617 -} 618 - 619 -proc twapi::cert_create {subject pubkey cissuer args} { 620 - set args [_cert_create_parse_options $args opts] 621 - 622 - parseargs args { 623 - {keyspec.arg signature {keyexchange signature}} 624 - {encoding.arg der {der pem}} 625 - } -maxleftover 0 -setvars 626 - 627 - # TBD - check that issuer is a CA 628 - 629 - set issuer_info [cert_info $cissuer] 630 - set issuer_blob [cert_name_to_blob [dict get $issuer_info -subject] -format x500] 631 - set sigalgo [dict get $issuer_info -signaturealgorithm] 632 - 633 - # If issuer cert has altnames, use they as issuer altnames for new cert 634 - set issuer_altnames [lindex [cert_extension $cissuer 2.5.29.17] 1] 635 - if {[llength $issuer_altnames]} { 636 - lappend opts(extensions) [_make_altnames_ext $issuer_altnames 0 1] 637 - } 638 - 639 - # The subject key id in issuer's cert will become the 640 - # authority key id in the new cert 641 - # TBD - if fail, get the CERT_KEY_IDENTIFIER_PROP_ID 642 - # 2.5.29.14 -> oid_subject_key_identifier 643 - set issuer_subject_key_id [cert_extension $cissuer 2.5.29.14] 644 - if {[string length [lindex $issuer_subject_key_id 1]] } { 645 - # 2.5.29.35 -> oid_authority_key_identifier 646 - lappend opts(extensions) [list 2.5.29.35 0 [list [lindex $issuer_subject_key_id 1] {} {}]] 647 - } 648 - 649 - # Generate a subject key identifier for this cert based on a hash 650 - # of the public key 651 - set subject_key_id [Twapi_HashPublicKeyInfo $pubkey] 652 - lappend opts(extensions) [list 2.5.29.14 0 $subject_key_id] 653 - 654 - set start [timelist_to_large_system_time $opts(start)] 655 - set end [timelist_to_large_system_time $opts(end)] 656 - 657 - # 2 -> CERT_V3 658 - # issuer_id and subject_id for the certificate are left empty 659 - # as recommended by gutman's X.509 paper 660 - set cert_info [list 2 $opts(serialnumber) $sigalgo $issuer_blob \ 661 - $start $end \ 662 - [cert_name_to_blob $subject] \ 663 - $pubkey {} {} \ 664 - $opts(extensions)] 665 - 666 - # We need to get the crypt provider for the issuer cert since 667 - # that is what will sign the new cert 668 - lassign [cert_property $cissuer key_prov_info] issuer_container issuer_provname issuer_provtype issuer_flags dontcare issuer_keyspec 669 - set hissuerprov [crypt_acquire $issuer_container -csp $issuer_provname -csptype $issuer_provtype -keysettype [expr {$issuer_flags & 0x20 ? "machine" : "user"}]] 670 - trap { 671 - # 0x10001 -> X509_ASN_ENCODING, 2 -> X509_CERT_TO_BE_SIGNED 672 - set enc [CryptSignAndEncodeCertificate $hissuerprov $issuer_keyspec \ 673 - 0x10001 2 $cert_info $sigalgo] 674 - 675 - if {$encoding eq "pem"} { 676 - # 0 -> CRYPT_STRING_BASE64HEADER 677 - # 0x80000000 -> LF-only, not CRLF 678 - return [CryptBinaryToString $enc 0x80000000] 679 - } else { 680 - return $enc 681 - } 682 - } finally { 683 - # TBD - test to make sure ok to close this if caller had 684 - # it open 685 - crypt_free $hissuerprov 686 - } 687 -} 688 - 689 -proc twapi::cert_tls_verify {hcert args} { 690 - 691 - parseargs args { 692 - {ignoreerrors.arg {}} 693 - {cacheendcert.bool 0 0x1} 694 - {revocationcheckcacheonly.bool 0 0x80000000} 695 - {urlretrievalcacheonly.bool 0 0x4} 696 - {disablepass1qualityfiltering.bool 0 0x40} 697 - {returnlowerqualitycontexts.bool 0 0x80} 698 - {disableauthrootautoupdate.bool 0 0x100} 699 - {revocationcheck.arg all {none all leaf excluderoot}} 700 - usageall.arg 701 - usageany.arg 702 - {engine.arg user {user machine}} 703 - {timestamp.arg ""} 704 - {hstore.arg NULL} 705 - {trustedroots.arg} 706 - server.arg 707 - } -setvars -maxleftover 0 708 - 709 - set flags [dict! {none 0 all 0x20000000 leaf 0x10000000 excluderoot 0x40000000} $revocationcheck] 710 - set flags [tcl::mathop::| $flags $cacheendcert $revocationcheckcacheonly $urlretrievalcacheonly $disablepass1qualityfiltering $returnlowerqualitycontexts $disableauthrootautoupdate] 711 - 712 - set usage_op 1; # USAGE_MATCH_TYPE_OR 713 - if {[info exists usageall]} { 714 - if {[info exists usageany]} { 715 - error "Only one of -usageall and -usageany may be specified" 716 - } 717 - set usage_op 0; # USAGE_MATCH_TYPE_AND 718 - set usage [_get_enhkey_usage_oids $usageall] 719 - } elseif {[info exists usageany]} { 720 - set usage [_get_enhkey_usage_oids $usageany] 721 - } else { 722 - if {[info exists server]} { 723 - set usage [_get_enhkey_usage_oids [list server_auth]] 724 - } else { 725 - set usage [_get_enhkey_usage_oids [list client_auth]] 726 - } 727 - } 728 - 729 - set chainh [CertGetCertificateChain \ 730 - [dict* {user NULL machine {1 HCERTCHAINENGINE}} $engine] \ 731 - $hcert $timestamp $hstore \ 732 - [list [list $usage_op $usage]] $flags] 733 - 734 - trap { 735 - set verify_flags 0 736 - foreach ignore $ignoreerrors { 737 - set verify_flags [expr {$verify_flags | [dict! { 738 - time 0x07 739 - basicconstraints 0x08 740 - unknownca 0x10 741 - usage 0x20 742 - name 0x40 743 - policy 0x80 744 - revocation 0xf00 745 - criticalextensions 0x2000 746 - } $ignore]}] 747 - } 748 - 749 - if {[info exists server]} { 750 - set role 2; # AUTHTYPE_SERVER 751 - } else { 752 - set role 1; # AUTHTYPE_CLIENT 753 - set server "" 754 - } 755 - 756 - # I have no clue as to why some of these options have to 757 - # be specified in two different places 758 - set checks 0 759 - foreach {verify check} { 760 - 0x7 0x2000 761 - 0xf00 0x80 762 - 0x10 0x100 763 - 0x20 0x200 764 - 0x40 0x1000 765 - } { 766 - if {$verify_flags & $verify} { 767 - set checks [expr {$checks | $check}] 768 - } 769 - } 770 - 771 - set status [Twapi_CertVerifyChainPolicySSL $chainh [list $verify_flags [list $role $checks $server]]] 772 - 773 - # If caller had provided additional trusted roots that are not 774 - # in the Windows trusted store, and the error is that the root is 775 - # untrusted, see if the root cert is one of the passed trusted ones 776 - if {$status == 0x800B0109 && 777 - [info exists trustedroots] && 778 - [llength $trustedroots]} { 779 - set chains [twapi::Twapi_CertChainContexts $chainh] 780 - set simple_chains [lindex $chains 1] 781 - # We will only deal when there is a single possible chain else 782 - # the recheck becomes very complicated as we are not sure if 783 - # the recheck will employ the same chain or not. 784 - if {[llength $simple_chains] == 1} { 785 - set certs_in_chain [lindex $simple_chains 0 1] 786 - # Get thumbprint of root cert 787 - set thumbprint [cert_thumbprint [lindex $certs_in_chain end 0]] 788 - # Match against each trusted root 789 - set trusted 0 790 - foreach trusted_cert $trustedroots { 791 - if {$thumbprint eq [cert_thumbprint $trusted_cert]} { 792 - set trusted 1 793 - break 794 - } 795 - } 796 - if {$trusted} { 797 - # Yes, the root is trusted. It is not enough to 798 - # say validation is ok because even if root 799 - # is trusted, other errors might show up 800 - # once untrusted roots are ignored. So we have 801 - # to call the verification again. 802 - # 0x10 -> CERT_CHAIN_POLICY_ALLOW_UNKNOWN_CA_FLAG 803 - set verify_flags [expr {$verify_flags | 0x10}] 804 - # 0x100 -> SECURITY_FLAG_IGNORE_UNKNOWN_CA 805 - set checks [expr {$checks | 0x100}] 806 - # Retry the call ignoring root errors 807 - set status [Twapi_CertVerifyChainPolicySSL $chainh [list $verify_flags [list $role $checks $server]]] 808 - } 809 - } 810 - } 811 - 812 - return [dict* { 813 - 0x00000000 ok 814 - 0x80096004 signature 815 - 0x80092010 revoked 816 - 0x800b0109 untrustedroot 817 - 0x800b010d untrustedtestroot 818 - 0x800b010a chaining 819 - 0x800b0110 wrongusage 820 - 0x800b0101 expired 821 - 0x800b0114 name 822 - 0x800b0113 policy 823 - 0x80096019 basicconstraints 824 - 0x800b0105 criticalextension 825 - 0x800b0102 validityperiodnesting 826 - 0x80092012 norevocationcheck 827 - 0x80092013 revocationoffline 828 - 0x800b010f cnmatch 829 - 0x800b0106 purpose 830 - 0x800b0103 carole 831 - } [hex32 $status]] 832 - } finally { 833 - if {[info exists certs_in_chain]} { 834 - foreach cert_stat $certs_in_chain { 835 - cert_release [lindex $cert_stat 0] 836 - } 837 - } 838 - CertFreeCertificateChain $chainh 839 - } 840 - 841 - return $status 842 -} 843 - 844 -proc twapi::cert_locate_private_key {hcert args} { 845 - parseargs args { 846 - {keysettype.arg any {any user machine}} 847 - {silent 0 0x40} 848 - } -maxleftover 0 -setvars 849 - 850 - return [CryptFindCertificateKeyProvInfo $hcert \ 851 - [expr {$silent | [dict get {any 0 user 1 machine 2} $keysettype]}]] 852 -} 853 - 854 -proc twapi::cert_request_parse {req args} { 855 - parseargs args { 856 - {encoding.arg der {der pem}} 857 - } -setvars -maxleftover 0 858 - 859 - if {$encoding eq "pem"} { 860 - # 3 -> CRYPT_STRING_BASE64REQUESTHEADER 861 - set req [CryptStringToBinary $req 3] 862 - } 863 - 864 - # 4 -> X509_CERT_REQUEST_TO_BE_SIGNED 865 - lassign [::twapi::CryptDecodeObjectEx 4 $req] ver subject pubkey attrs 866 - lappend reqdict version $ver pubkey $pubkey attributes $attrs 867 - lappend reqdict subject [cert_blob_to_name $subject] 868 - foreach attr $attrs { 869 - lassign $attr oid values 870 - if {$oid eq "1.2.840.113549.1.9.14"} { 871 - # Extensions 872 - set extensions {} 873 - foreach ext [lindex $values 0] { 874 - lassign $ext oid critical value 875 - set value [_cert_decode_extension $oid $value] 876 - switch -exact -- $oid { 877 - 2.5.29.15 { set oidname -keyusage } 878 - 2.5.29.17 { set oidname -altnames } 879 - 2.5.29.19 { set oidname -basicconstraints } 880 - 2.5.29.37 { set oidname -enhkeyusage } 881 - default { set oidname $oid } 882 - } 883 - lappend extensions $oidname [list $value $critical] 884 - } 885 - lappend reqdict extensions $extensions 886 - } 887 - } 888 - 889 - return $reqdict 890 -} 891 - 892 - 893 -proc twapi::cert_request_create {subject hprov keyspec args} { 894 - set args [_cert_create_parse_options $args opts] 895 - # TBD - barf if any elements other than extensions is set 896 - # TBD - document signaturealgorithmid 897 - parseargs args { 898 - {signaturealgorithmid.arg oid_rsa_sha1rsa} 899 - {encoding.arg der {der pem}} 900 - } -setvars -maxleftover 0 901 - 902 - set sigoid [oid $signaturealgorithmid] 903 - if {$sigoid ni [list [oid oid_rsa_sha1rsa] [oid oid_rsa_md5rsa] [oid oid_x957_sha1dsa]]} { 904 - badargs! "Invalid signature algorithm '$sigalg'" 905 - } 906 - set keyspec [twapi::_crypt_keyspec $keyspec] 907 - # 0x10001 -> PKCS_7_ASN_ENCODING|X509_ASN_ENCODING 908 - # Pass oid_rsa_rsa as that seems to be what OPENSSL understands in 909 - # a CSR 910 - set pubkeyinfo [crypt_public_key $hprov $keyspec oid_rsa_rsa] 911 - set attrs [list 0 [cert_name_to_blob $subject] $pubkeyinfo] 912 - if {[llength $opts(extensions)]} { 913 - lappend attrs [list [list [oid oid_rsa_certextensions] [list $opts(extensions)]]] 914 - } else { 915 - lappend attrs {} 916 - } 917 - set req [CryptSignAndEncodeCertificate $hprov $keyspec 0x10001 4 $attrs $sigoid] 918 - if {$encoding eq "pem"} { 919 - # 3 -> CRYPT_STRING_BASE64REQUESTHEADER 920 - # 0x80000000 -> LF-only, not CRLF 921 - return [CryptBinaryToString $req 0x80000003] 922 - } else { 923 - return $req 924 - } 925 -} 926 - 927 - 928 -################################################################ 929 -# Cryptographic context commands 930 - 931 -proc twapi::crypt_acquire {keycontainer args} { 932 - parseargs args { 933 - csp.arg 934 - {csptype.arg prov_rsa_full} 935 - {keysettype.arg user {user machine}} 936 - {create.bool 0 0x8} 937 - {silent.bool 0 0x40} 938 - {verifycontext.bool 0 0xf0000000} 939 - } -maxleftover 0 -nulldefault -setvars 940 - 941 - # Based on http://support.microsoft.com/kb/238187, if verifycontext 942 - # is not specified, default container must not be used as keys 943 - # from different applications might overwrite. The docs for 944 - # CryptAcquireContext say keycontainer must be empty if verifycontext 945 - # is specified. Thus they are mutually exclusive. 946 - if {! $verifycontext} { 947 - if {$keycontainer eq ""} { 948 - badargs! "Option -verifycontext must be specified for the default key container." 949 - } 950 - } 951 - 952 - set flags [expr {$create | $silent | $verifycontext}] 953 - if {$keysettype eq "machine"} { 954 - incr flags 0x20; # CRYPT_KEYSET_MACHINE 955 - } 956 - 957 - return [CryptAcquireContext $keycontainer $csp [_csp_type_name_to_id $csptype] $flags] 958 -} 959 - 960 -proc twapi::crypt_free {hcrypt} { 961 - twapi::CryptReleaseContext $hcrypt 962 -} 963 - 964 -proc twapi::crypt_key_container_delete {keycontainer args} { 965 - parseargs args { 966 - csp.arg 967 - {csptype.arg prov_rsa_full} 968 - {keysettype.arg user {machine user}} 969 - force 970 - } -maxleftover 0 -nulldefault -setvars 971 - 972 - if {$keycontainer eq "" && ! $force} { 973 - error "Default container cannot be deleted unless the -force option is specified" 974 - } 975 - 976 - set flags 0x10; # CRYPT_DELETEKEYSET 977 - if {$keysettype eq "machine"} { 978 - incr flags 0x20; # CRYPT_MACHINE_KEYSET 979 - } 980 - 981 - return [CryptAcquireContext $keycontainer $csp [_csp_type_name_to_id $csptype] $flags] 982 -} 983 - 984 -proc twapi::crypt_key_generate {hprov algid args} { 985 - 986 - array set opts [parseargs args { 987 - {archivable.bool 0 0x4000} 988 - {salt.bool 0 4} 989 - {exportable.bool 0 1} 990 - {pregen.bool 0x40} 991 - {userprotected.bool 0 2} 992 - {nosalt40.bool 0 0x10} 993 - {size.int 0} 994 - } -maxleftover 0] 995 - 996 - if {![string is integer -strict $algid]} { 997 - # See wincrypt.h in SDK 998 - switch -nocase -exact -- $algid { 999 - keyexchange {set algid 1} 1000 - signature {set algid 2} 1001 - default { 1002 - set id [CertOIDToAlgId [oid $algid]] 1003 - if {$id == 0} { 1004 - badargs! "Invalid algorithm id '$algid'" 1005 - } 1006 - set algid $id