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 9namespace 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 35proc 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 42proc 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 60interp alias {} twapi::large_system_time_to_secs {} twapi::large_system_time_to_secs_since_1970 61proc 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 72proc 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 78proc 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 84proc 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 108proc twapi::free_library {libh} { 109 FreeLibrary $libh 110} 111 112# Format message string - will raise exception if insufficient number 113# of arguments 114proc 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 193proc 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 290proc twapi::revert_to_self {{opt ""}} { 291 RevertToSelf 292} 293 294# For backward compatibility 295interp alias {} twapi::expand_environment_strings {} twapi::expand_environment_vars 296 297proc 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 511proc 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 543proc 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 705proc 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 723proc 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 749proc 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. 758proc 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 774proc 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 822proc 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 884proc 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 901proc 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 923proc 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 952proc 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} 964proc twapi::nil_uuid {} { 965 return [UuidCreateNil] 966} 967 968proc twapi::new_guid {} { 969 return [canonicalize_guid [new_uuid]] 970} 971 972# Get a handle to a LSA policy. TBD - document 973proc 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 984proc twapi::close_lsa_policy_handle {h} { 985 LsaClose $h 986 return 987} 988 989# Eventlog stuff in the base package 990 991namespace 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 998proc 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 1042proc 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 1056proc 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 1090proc 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 1108proc 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 1116proc 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 1153proc 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 1199proc 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 1206proc 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 1225proc 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 1241proc 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 1251if {[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 1287namespace eval twapi::recordarray {} 1288 1289proc twapi::recordarray::size {ra} { 1290 return [llength [lindex $ra 1]] 1291} 1292 1293proc twapi::recordarray::fields {ra} { 1294 return [lindex $ra 0] 1295} 1296 1297proc 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 1327proc twapi::recordarray::range {ra low high} { 1328 return [list [lindex $ra 0] [lrange [lindex $ra 1] $low $high]] 1329} 1330 1331proc 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 1339proc twapi::recordarray::cell {ra row field} { 1340 return [lindex [lindex $ra 1 $row] [twapi::enum [lindex $ra 0] $field]] 1341} 1342 1343proc 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 1355proc 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 1372proc 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 1389proc 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 1425proc 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 1437proc 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 1457namespace 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 1463proc 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 1547