1# 2# Copyright (c) 2012 Ashok P. Nadkarni 3# All rights reserved. 4# 5# See the file LICENSE for license 6 7package require twapi_ui; # SetCursorPos etc. 8 9# Enable window input 10proc twapi::enable_window_input {hwin} { 11 return [expr {[EnableWindow $hwin 1] != 0}] 12} 13 14# Disable window input 15proc twapi::disable_window_input {hwin} { 16 return [expr {[EnableWindow $hwin 0] != 0}] 17} 18 19# CHeck if window input is enabled 20proc twapi::window_input_enabled {hwin} { 21 return [IsWindowEnabled $hwin] 22} 23 24# Simulate user input 25proc twapi::send_input {inputlist} { 26 array set input_defs { 27 MOUSEEVENTF_MOVE 0x0001 28 MOUSEEVENTF_LEFTDOWN 0x0002 29 MOUSEEVENTF_LEFTUP 0x0004 30 MOUSEEVENTF_RIGHTDOWN 0x0008 31 MOUSEEVENTF_RIGHTUP 0x0010 32 MOUSEEVENTF_MIDDLEDOWN 0x0020 33 MOUSEEVENTF_MIDDLEUP 0x0040 34 MOUSEEVENTF_XDOWN 0x0080 35 MOUSEEVENTF_XUP 0x0100 36 MOUSEEVENTF_WHEEL 0x0800 37 MOUSEEVENTF_VIRTUALDESK 0x4000 38 MOUSEEVENTF_ABSOLUTE 0x8000 39 40 KEYEVENTF_EXTENDEDKEY 0x0001 41 KEYEVENTF_KEYUP 0x0002 42 KEYEVENTF_UNICODE 0x0004 43 KEYEVENTF_SCANCODE 0x0008 44 45 XBUTTON1 0x0001 46 XBUTTON2 0x0002 47 } 48 49 set inputs [list ] 50 foreach input $inputlist { 51 if {[string equal [lindex $input 0] "mouse"]} { 52 lassign $input mouse xpos ypos 53 set mouseopts [lrange $input 3 end] 54 array unset opts 55 array set opts [parseargs mouseopts { 56 relative moved 57 ldown lup rdown rup mdown mup x1down x1up x2down x2up 58 wheel.int 59 }] 60 set flags 0 61 if {! $opts(relative)} { 62 set flags $input_defs(MOUSEEVENTF_ABSOLUTE) 63 } 64 65 if {[info exists opts(wheel)]} { 66 if {($opts(x1down) || $opts(x1up) || $opts(x2down) || $opts(x2up))} { 67 error "The -wheel input event attribute may not be specified with -x1up, -x1down, -x2up or -x2down events" 68 } 69 set mousedata $opts(wheel) 70 set flags $input_defs(MOUSEEVENTF_WHEEL) 71 } else { 72 if {$opts(x1down) || $opts(x1up)} { 73 if {$opts(x2down) || $opts(x2up)} { 74 error "The -x1down, -x1up mouse input attributes are mutually exclusive with -x2down, -x2up attributes" 75 } 76 set mousedata $input_defs(XBUTTON1) 77 } else { 78 if {$opts(x2down) || $opts(x2up)} { 79 set mousedata $input_defs(XBUTTON2) 80 } else { 81 set mousedata 0 82 } 83 } 84 } 85 foreach {opt flag} { 86 moved MOVE 87 ldown LEFTDOWN 88 lup LEFTUP 89 rdown RIGHTDOWN 90 rup RIGHTUP 91 mdown MIDDLEDOWN 92 mup MIDDLEUP 93 x1down XDOWN 94 x1up XUP 95 x2down XDOWN 96 x2up XUP 97 } { 98 if {$opts($opt)} { 99 set flags [expr {$flags | $input_defs(MOUSEEVENTF_$flag)}] 100 } 101 } 102 103 lappend inputs [list mouse $xpos $ypos $mousedata $flags] 104 105 } else { 106 lassign $input inputtype vk scan keyopts 107 if {"-extended" ni $keyopts} { 108 set extended 0 109 } else { 110 set extended $input_defs(KEYEVENTF_EXTENDEDKEY) 111 } 112 if {"-usescan" ni $keyopts} { 113 set usescan 0 114 } else { 115 set usescan $input_defs(KEYEVENTF_SCANCODE) 116 } 117 switch -exact -- $inputtype { 118 keydown { 119 lappend inputs [list key $vk $scan [expr {$extended|$usescan}]] 120 } 121 keyup { 122 lappend inputs [list key $vk $scan \ 123 [expr {$extended 124 | $usescan 125 | $input_defs(KEYEVENTF_KEYUP) 126 }]] 127 } 128 key { 129 lappend inputs [list key $vk $scan [expr {$extended|$usescan}]] 130 lappend inputs [list key $vk $scan \ 131 [expr {$extended 132 | $usescan 133 | $input_defs(KEYEVENTF_KEYUP) 134 }]] 135 } 136 unicode { 137 lappend inputs [list key 0 $scan $input_defs(KEYEVENTF_UNICODE)] 138 lappend inputs [list key 0 $scan \ 139 [expr {$input_defs(KEYEVENTF_UNICODE) 140 | $input_defs(KEYEVENTF_KEYUP) 141 }]] 142 } 143 default { 144 error "Unknown input type '$inputtype'" 145 } 146 } 147 } 148 } 149 150 SendInput $inputs 151} 152 153# Block the input 154proc twapi::block_input {} { 155 return [BlockInput 1] 156} 157 158# Unblock the input 159proc twapi::unblock_input {} { 160 return [BlockInput 0] 161} 162 163# Send the given set of characters to the input queue 164proc twapi::send_input_text {s} { 165 return [Twapi_SendUnicode $s] 166} 167 168# send_keys - uses same syntax as VB SendKeys function 169proc twapi::send_keys {keys} { 170 set inputs [_parse_send_keys $keys] 171 send_input $inputs 172} 173 174 175# Handles a hotkey notification 176proc twapi::_hotkey_handler {msg atom key msgpos ticks} { 177 variable _hotkeys 178 179 # Note it is not an error if a hotkey does not exist since it could 180 # have been deregistered in the time between hotkey input and receiving it. 181 set code 0 182 if {[info exists _hotkeys($atom)]} { 183 foreach handler $_hotkeys($atom) { 184 set code [catch {uplevel #0 $handler} msg] 185 switch -exact -- $code { 186 0 { 187 # Normal, keep going 188 } 189 1 { 190 # Error - put in background and abort 191 after 0 [list error $msg $::errorInfo $::errorCode] 192 break 193 } 194 3 { 195 break; # Ignore remaining handlers 196 } 197 default { 198 # Keep going 199 } 200 } 201 } 202 } 203 return -code $code "" 204} 205 206proc twapi::register_hotkey {hotkey script args} { 207 variable _hotkeys 208 209 # 0x312 -> WM_HOTKEY 210 _register_script_wm_handler 0x312 [list [namespace current]::_hotkey_handler] 1 211 212 array set opts [parseargs args { 213 append 214 } -maxleftover 0] 215 216# set script [lrange $script 0 end]; # Ensure a valid list 217 218 lassign [_hotkeysyms_to_vk $hotkey] modifiers vk 219 set hkid "twapi_hk_${vk}_$modifiers" 220 set atom [GlobalAddAtom $hkid] 221 if {[info exists _hotkeys($atom)]} { 222 GlobalDeleteAtom $atom; # Undo above AddAtom since already there 223 if {$opts(append)} { 224 lappend _hotkeys($atom) $script 225 } else { 226 set _hotkeys($atom) [list $script]; # Replace previous script 227 } 228 return $atom 229 } 230 trap { 231 RegisterHotKey $atom $modifiers $vk 232 } onerror {} { 233 GlobalDeleteAtom $atom; # Undo above AddAtom 234 rethrow 235 } 236 set _hotkeys($atom) [list $script]; # Replace previous script 237 return $atom 238} 239 240proc twapi::unregister_hotkey {atom} { 241 variable _hotkeys 242 if {[info exists _hotkeys($atom)]} { 243 UnregisterHotKey $atom 244 GlobalDeleteAtom $atom 245 unset _hotkeys($atom) 246 } 247} 248 249 250# Simulate clicking a mouse button 251proc twapi::click_mouse_button {button} { 252 switch -exact -- $button { 253 1 - 254 left { set down -ldown ; set up -lup} 255 2 - 256 right { set down -rdown ; set up -rup} 257 3 - 258 middle { set down -mdown ; set up -mup} 259 x1 { set down -x1down ; set up -x1up} 260 x2 { set down -x2down ; set up -x2up} 261 default {error "Invalid mouse button '$button' specified"} 262 } 263 264 send_input [list \ 265 [list mouse 0 0 $down] \ 266 [list mouse 0 0 $up]] 267 return 268} 269 270# Simulate mouse movement 271proc twapi::move_mouse {xpos ypos {mode ""}} { 272 # If mouse trails are enabled, it leaves traces when the mouse is 273 # moved and does not clear them until mouse is moved again. So 274 # we temporarily disable mouse trails if we can 275 276 if {[llength [info commands ::twapi::get_system_parameters_info]] != 0} { 277 set trail [get_system_parameters_info SPI_GETMOUSETRAILS] 278 set_system_parameters_info SPI_SETMOUSETRAILS 0 279 } 280 switch -exact -- $mode { 281 -relative { 282 lappend cmd -relative 283 lassign [GetCursorPos] curx cury 284 incr xpos $curx 285 incr ypos $cury 286 } 287 -absolute - 288 "" { } 289 default { error "Invalid mouse movement mode '$mode'" } 290 } 291 292 SetCursorPos $xpos $ypos 293 294 # Restore trail setting if we had disabled it and it was originally enabled 295 if {[info exists trail] && $trail} { 296 set_system_parameters_info SPI_SETMOUSETRAILS $trail 297 } 298} 299 300# Simulate turning of the mouse wheel 301proc twapi::turn_mouse_wheel {wheelunits} { 302 send_input [list [list mouse 0 0 -relative -wheel $wheelunits]] 303 return 304} 305 306# Get the mouse/cursor position 307proc twapi::get_mouse_location {} { 308 return [GetCursorPos] 309} 310 311proc twapi::get_input_idle_time {} { 312 # The formats are to convert wrapped 32bit signed to unsigned 313 set last_event [format 0x%x [GetLastInputInfo]] 314 set now [format 0x%x [GetTickCount]] 315 316 # Deal with wrap around 317 if {$now >= $last_event} { 318 return [expr {$now - $last_event}] 319 } else { 320 return [expr {$now + (0xffffffff - $last_event) + 1}] 321 } 322} 323 324# Initialize the virtual key table 325proc twapi::_init_vk_map {} { 326 variable vk_map 327 328 if {![info exists vk_map]} { 329 # Map tokens to VK_* key codes 330 array set vk_map { 331 + {0x10 0} ^ {0x11 0} % {0x12 0} BACK {0x08 0} 332 BACKSPACE {0x08 0} BS {0x08 0} BKSP {0x08 0} TAB {0x09 0} 333 CLEAR {0x0C 0} RETURN {0x0D 0} ENTER {0x0D 0} SHIFT {0x10 0} 334 CONTROL {0x11 0} MENU {0x12 0} ALT {0x12 0} PAUSE {0x13 0} 335 BREAK {0x13 0} CAPITAL {0x14 0} CAPSLOCK {0x14 0} 336 KANA {0x15 0} HANGEUL {0x15 0} HANGUL {0x15 0} JUNJA {0x17 0} 337 FINAL {0x18 0} HANJA {0x19 0} KANJI {0x19 0} ESCAPE {0x1B 0} 338 ESC {0x1B 0} CONVERT {0x1C 0} NONCONVERT {0x1D 0} 339 ACCEPT {0x1E 0} MODECHANGE {0x1F 0} SPACE {0x20 0} 340 PRIOR {0x21 0} PGUP {0x21 0} NEXT {0x22 0} PGDN {0x22 0} 341 END {0x23 0} HOME {0x24 0} LEFT {0x25 0} UP {0x26 0} 342 RIGHT {0x27 0} DOWN {0x28 0} SELECT {0x29 0} 343 PRINT {0x2A 0} PRTSC {0x2C 0} EXECUTE {0x2B 0} 344 SNAPSHOT {0x2C 0} INSERT {0x2D 0} INS {0x2D 0} 345 DELETE {0x2E 0} DEL {0x2E 0} HELP {0x2F 0} LWIN {0x5B 0} 346 RWIN {0x5C 0} APPS {0x5D 0} SLEEP {0x5F 0} NUMPAD0 {0x60 0} 347 NUMPAD1 {0x61 0} NUMPAD2 {0x62 0} NUMPAD3 {0x63 0} 348 NUMPAD4 {0x64 0} NUMPAD5 {0x65 0} NUMPAD6 {0x66 0} 349 NUMPAD7 {0x67 0} NUMPAD8 {0x68 0} NUMPAD9 {0x69 0} 350 MULTIPLY {0x6A 0} ADD {0x6B 0} SEPARATOR {0x6C 0} 351 SUBTRACT {0x6D 0} DECIMAL {0x6E 0} DIVIDE {0x6F 0} 352 F1 {0x70 0} F2 {0x71 0} F3 {0x72 0} F4 {0x73 0} 353 F5 {0x74 0} F6 {0x75 0} F7 {0x76 0} F8 {0x77 0} 354 F9 {0x78 0} F10 {0x79 0} F11 {0x7A 0} F12 {0x7B 0} 355 F13 {0x7C 0} F14 {0x7D 0} F15 {0x7E 0} F16 {0x7F 0} 356 F17 {0x80 0} F18 {0x81 0} F19 {0x82 0} F20 {0x83 0} 357 F21 {0x84 0} F22 {0x85 0} F23 {0x86 0} F24 {0x87 0} 358 NUMLOCK {0x90 0} SCROLL {0x91 0} SCROLLLOCK {0x91 0} 359 LSHIFT {0xA0 0} RSHIFT {0xA1 0 -extended} LCONTROL {0xA2 0} 360 RCONTROL {0xA3 0 -extended} LMENU {0xA4 0} LALT {0xA4 0} 361 RMENU {0xA5 0 -extended} RALT {0xA5 0 -extended} 362 BROWSER_BACK {0xA6 0} BROWSER_FORWARD {0xA7 0} 363 BROWSER_REFRESH {0xA8 0} BROWSER_STOP {0xA9 0} 364 BROWSER_SEARCH {0xAA 0} BROWSER_FAVORITES {0xAB 0} 365 BROWSER_HOME {0xAC 0} VOLUME_MUTE {0xAD 0} 366 VOLUME_DOWN {0xAE 0} VOLUME_UP {0xAF 0} 367 MEDIA_NEXT_TRACK {0xB0 0} MEDIA_PREV_TRACK {0xB1 0} 368 MEDIA_STOP {0xB2 0} MEDIA_PLAY_PAUSE {0xB3 0} 369 LAUNCH_MAIL {0xB4 0} LAUNCH_MEDIA_SELECT {0xB5 0} 370 LAUNCH_APP1 {0xB6 0} LAUNCH_APP2 {0xB7 0} 371 } 372 } 373} 374 375 376# Constructs a list of input events by parsing a string in the format 377# used by Visual Basic's SendKeys function 378proc twapi::_parse_send_keys {keys {inputs ""}} { 379 variable vk_map 380 381 _init_vk_map 382 383 set n [string length $keys] 384 set trailer [list ] 385 for {set i 0} {$i < $n} {incr i} { 386 set key [string index $keys $i] 387 switch -exact -- $key { 388 "+" - 389 "^" - 390 "%" { 391 lappend inputs [concat keydown $vk_map($key)] 392 set trailer [linsert $trailer 0 [concat keyup $vk_map($key)]] 393 } 394 "~" { 395 lappend inputs [concat key $vk_map(RETURN)] 396 set inputs [concat $inputs $trailer] 397 set trailer [list ] 398 } 399 "(" { 400 # Recurse for paren expression 401 set nextparen [string first ")" $keys $i] 402 if {$nextparen == -1} { 403 error "Invalid key sequence - unterminated (" 404 } 405 set inputs [concat $inputs [_parse_send_keys [string range $keys [expr {$i+1}] [expr {$nextparen-1}]]]] 406 set inputs [concat $inputs $trailer] 407 set trailer [list ] 408 set i $nextparen 409 } 410 "\{" { 411 set nextbrace [string first "\}" $keys $i] 412 if {$nextbrace == -1} { 413 error "Invalid key sequence - unterminated $key" 414 } 415 416 if {$nextbrace == ($i+1)} { 417 # Look for the next brace 418 set nextbrace [string first "\}" $keys $nextbrace] 419 if {$nextbrace == -1} { 420 error "Invalid key sequence - unterminated $key" 421 } 422 } 423 424 set key [string range $keys [expr {$i+1}] [expr {$nextbrace-1}]] 425 set bracepat [string toupper $key] 426 if {[info exists vk_map($bracepat)]} { 427 lappend inputs [concat key $vk_map($bracepat)] 428 } else { 429 # May be pattern of the type {C} or {C N} where 430 # C is a single char and N is a count 431 set c [string index $key 0] 432 set count [string trim [string range $key 1 end]] 433 scan $c %c unicode 434 if {[string length $count] == 0} { 435 set count 1 436 } else { 437 # Note if $count is not an integer, an error 438 # will be generated as we want 439 incr count 0 440 if {$count < 0} { 441 error "Negative character count specified in braced key input" 442 } 443 } 444 for {set j 0} {$j < $count} {incr j} { 445 lappend inputs [list unicode 0 $unicode] 446 } 447 } 448 set inputs [concat $inputs $trailer] 449 set trailer [list ] 450 set i $nextbrace 451 } 452 default { 453 scan $key %c unicode 454 # Alphanumeric keys are treated separately so they will 455 # work correctly with control modifiers 456 if {$unicode >= 0x61 && $unicode <= 0x7A} { 457 # Lowercase letters 458 lappend inputs [list key [expr {$unicode-32}] 0] 459 } elseif {$unicode >= 0x30 && $unicode <= 0x39} { 460 # Digits 461 lappend inputs [list key $unicode 0] 462 } else { 463 lappend inputs [list unicode 0 $unicode] 464 } 465 set inputs [concat $inputs $trailer] 466 set trailer [list ] 467 } 468 } 469 } 470 return $inputs 471} 472 473# utility procedure to map symbolic hotkey to {modifiers virtualkey} 474# We allow modifier map to be passed in because different api's use 475# different bits for key modifiers 476proc twapi::_hotkeysyms_to_vk {hotkey {modifier_map {ctrl 2 control 2 alt 1 menu 1 shift 4 win 8}}} { 477 variable vk_map 478 479 _init_vk_map 480 481 set keyseq [split [string tolower $hotkey] -] 482 set key [lindex $keyseq end] 483 484 # Convert modifiers to bitmask 485 set modifiers 0 486 foreach modifier [lrange $keyseq 0 end-1] { 487 setbits modifiers [dict! $modifier_map [string tolower $modifier]] 488 } 489 # Map the key to a virtual key code 490 if {[string length $key] == 1} { 491 # Single character 492 scan $key %c unicode 493 494 # Only allow alphanumeric keys and a few punctuation symbols 495 # since keyboard layouts are not standard 496 if {$unicode >= 0x61 && $unicode <= 0x7A} { 497 # Lowercase letters - change to upper case virtual keys 498 set vk [expr {$unicode-32}] 499 } elseif {($unicode >= 0x30 && $unicode <= 0x39) 500 || ($unicode >= 0x41 && $unicode <= 0x5A)} { 501 # Digits or upper case 502 set vk $unicode 503 } else { 504 error "Only alphanumeric characters may be specified for the key. For non-alphanumeric characters, specify the virtual key code" 505 } 506 } elseif {[info exists vk_map($key)]} { 507 # It is a virtual key name 508 set vk [lindex $vk_map($key) 0] 509 } elseif {[info exists vk_map([string toupper $key])]} { 510 # It is a virtual key name 511 set vk [lindex $vk_map([string toupper $key]) 0] 512 } elseif {[string is integer -strict $key]} { 513 # Actual virtual key specification 514 set vk $key 515 } else { 516 error "Unknown or invalid key specifier '$key'" 517 } 518 519 return [list $modifiers $vk] 520} 521