You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
236 lines
6.9 KiB
236 lines
6.9 KiB
# |
|
# Copyright (c) 2010, Ashok P. Nadkarni |
|
# All rights reserved. |
|
# |
|
# See the file LICENSE for license |
|
|
|
namespace eval twapi { |
|
# Array maps handles we are waiting on to the ids of the registered waits |
|
variable _wait_handle_ids |
|
# Array maps id of registered wait to the corresponding callback scripts |
|
variable _wait_handle_scripts |
|
|
|
} |
|
|
|
proc twapi::cast_handle {h type} { |
|
# TBD - should this use pointer_from_address: |
|
# return [pointer_from_address [address_from_pointer $h] $type] |
|
return [list [lindex $h 0] $type] |
|
} |
|
|
|
proc twapi::close_handle {h} { |
|
|
|
# Cancel waits on the handle, if any |
|
cancel_wait_on_handle $h |
|
|
|
# Then close it |
|
CloseHandle $h |
|
} |
|
|
|
# Close multiple handles. In case of errors, collects them but keeps |
|
# closing remaining handles and only raises the error at the end. |
|
proc twapi::close_handles {args} { |
|
# The original definition for this was broken in that it would |
|
# gracefully accept non list parameters as a list of one. In 3.0 |
|
# the handle format has changed so this does not happen |
|
# naturally. We have to try and decipher whether it is a list |
|
# of handles or a single handle. |
|
|
|
foreach arg $args { |
|
if {[pointer? $arg]} { |
|
# Looks like a single handle |
|
if {[catch {close_handle $arg} msg]} { |
|
set erinfo $::errorInfo |
|
set ercode $::errorCode |
|
set ermsg $msg |
|
} |
|
} else { |
|
# Assume a list of handles |
|
foreach h $arg { |
|
if {[catch {close_handle $h} msg]} { |
|
set erinfo $::errorInfo |
|
set ercode $::errorCode |
|
set ermsg $msg |
|
} |
|
} |
|
} |
|
} |
|
|
|
if {[info exists erinfo]} { |
|
error $msg $erinfo $ercode |
|
} |
|
} |
|
|
|
# |
|
# Wait on a handle |
|
proc twapi::wait_on_handle {hwait args} { |
|
variable _wait_handle_ids |
|
variable _wait_handle_scripts |
|
|
|
# When we are invoked from callback, handle is always typed as HANDLE |
|
# so convert it so lookups succeed |
|
set h [cast_handle $hwait HANDLE] |
|
|
|
# 0x00000008 -> # WT_EXECUTEONCEONLY |
|
array set opts [parseargs args { |
|
{wait.int -1} |
|
async.arg |
|
{executeonce.bool false 0x00000008} |
|
}] |
|
|
|
if {![info exists opts(async)]} { |
|
if {[info exists _wait_handle_ids($h)]} { |
|
error "Attempt to synchronously wait on handle that is registered for an asynchronous wait." |
|
} |
|
|
|
set ret [WaitForSingleObject $h $opts(wait)] |
|
if {$ret == 0x80} { |
|
return abandoned |
|
} elseif {$ret == 0} { |
|
return signalled |
|
} elseif {$ret == 0x102} { |
|
return timeout |
|
} else { |
|
error "Unexpected value $ret returned from WaitForSingleObject" |
|
} |
|
} |
|
|
|
# async option specified |
|
|
|
# Do not wait on manual reset events as cpu will spin continuously |
|
# queueing events |
|
if {[pointer? $hwait HANDLE_MANUALRESETEVENT] && |
|
! $opts(executeonce) |
|
} { |
|
error "A handle to a manual reset event cannot be waited on asynchronously unless -executeonce is specified." |
|
} |
|
|
|
# If handle already registered, cancel previous registration. |
|
if {[info exists _wait_handle_ids($h)]} { |
|
cancel_wait_on_handle $h |
|
} |
|
|
|
|
|
set id [Twapi_RegisterWaitOnHandle $h $opts(wait) $opts(executeonce)] |
|
|
|
# Set now that successfully registered |
|
set _wait_handle_scripts($id) $opts(async) |
|
set _wait_handle_ids($h) $id |
|
|
|
return |
|
} |
|
|
|
# |
|
# Cancel an async wait on a handle |
|
proc twapi::cancel_wait_on_handle {h} { |
|
variable _wait_handle_ids |
|
variable _wait_handle_scripts |
|
|
|
if {[info exists _wait_handle_ids($h)]} { |
|
Twapi_UnregisterWaitOnHandle $_wait_handle_ids($h) |
|
unset _wait_handle_scripts($_wait_handle_ids($h)) |
|
unset _wait_handle_ids($h) |
|
} |
|
} |
|
|
|
# |
|
# Called from C when a handle is signalled or times out |
|
proc twapi::_wait_handler {id h event} { |
|
variable _wait_handle_ids |
|
variable _wait_handle_scripts |
|
|
|
# We ignore the following stale event cases - |
|
# - _wait_handle_ids($h) does not exist : the wait was canceled while |
|
# and event was queued |
|
# - _wait_handle_ids($h) exists but is different from $id - same |
|
# as prior case, except that a new wait has since been initiated |
|
# on the same handle value (which might have be for a different |
|
# resource |
|
|
|
if {[info exists _wait_handle_ids($h)] && |
|
$_wait_handle_ids($h) == $id} { |
|
uplevel #0 [linsert $_wait_handle_scripts($id) end $h $event] |
|
} |
|
|
|
return |
|
} |
|
|
|
# Get the handle for a Tcl channel |
|
proc twapi::get_tcl_channel_handle {chan direction} { |
|
set direction [expr {[string equal $direction "write"] ? 1 : 0}] |
|
return [Tcl_GetChannelHandle $chan $direction] |
|
} |
|
|
|
# Duplicate a OS handle |
|
proc twapi::duplicate_handle {h args} { |
|
variable my_process_handle |
|
|
|
array set opts [parseargs args { |
|
sourcepid.int |
|
targetpid.int |
|
access.arg |
|
inherit |
|
closesource |
|
} -maxleftover 0] |
|
|
|
# Assume source and target processes are us |
|
set source_ph $my_process_handle |
|
set target_ph $my_process_handle |
|
|
|
if {[string is wideinteger $h]} { |
|
set h [pointer_from_address $h HANDLE] |
|
} |
|
|
|
trap { |
|
set me [pid] |
|
# If source pid specified and is not us, get a handle to the process |
|
if {[info exists opts(sourcepid)] && $opts(sourcepid) != $me} { |
|
set source_ph [get_process_handle $opts(sourcepid) -access process_dup_handle] |
|
} |
|
|
|
# Ditto for target process... |
|
if {[info exists opts(targetpid)] && $opts(targetpid) != $me} { |
|
set target_ph [get_process_handle $opts(targetpid) -access process_dup_handle] |
|
} |
|
|
|
# Do we want to close the original handle (DUPLICATE_CLOSE_SOURCE) |
|
set flags [expr {$opts(closesource) ? 0x1: 0}] |
|
|
|
if {[info exists opts(access)]} { |
|
set access [_access_rights_to_mask $opts(access)] |
|
} else { |
|
# If no desired access is indicated, we want the same access as |
|
# the original handle |
|
set access 0 |
|
set flags [expr {$flags | 0x2}]; # DUPLICATE_SAME_ACCESS |
|
} |
|
|
|
|
|
set dup [DuplicateHandle $source_ph $h $target_ph $access $opts(inherit) $flags] |
|
|
|
# IF targetpid specified, return handle else literal |
|
# (even if targetpid is us) |
|
if {[info exists opts(targetpid)]} { |
|
set dup [pointer_to_address $dup] |
|
} |
|
} finally { |
|
if {$source_ph != $my_process_handle} { |
|
CloseHandle $source_ph |
|
} |
|
if {$target_ph != $my_process_handle} { |
|
CloseHandle $source_ph |
|
} |
|
} |
|
|
|
return $dup |
|
} |
|
|
|
proc twapi::set_handle_inheritance {h inherit} { |
|
# 1 -> HANDLE_FLAG_INHERIT |
|
SetHandleInformation $h 0x1 [expr {$inherit ? 1 : 0}] |
|
} |
|
|
|
proc twapi::get_handle_inheritance {h} { |
|
# 1 -> HANDLE_FLAG_INHERIT |
|
return [expr {[GetHandleInformation $h] & 1}] |
|
}
|
|
|