punkshell/src/punk86.vfs/lib/twapi4.7.2/win.tcl

#
# Copyright (c) 2012 Ashok P. Nadkarni
# All rights reserved.
#
# See the file LICENSE for license

# Contains common windowing and notification infrastructure

namespace eval twapi {
    variable null_hwin ""

    # Windows messages that are directly accessible from script. These
    # are handled by the default notifications window and passed to
    # the twapi::_script_wm_handler. These messages must be in the
    # range (1056 = 1024+32) - (1024+32+31) (see twapi_wm.h)
    variable _wm_script_msgs
    array set _wm_script_msgs {
        TASKBAR_RESTART      1031
        NOTIFY_ICON_CALLBACK 1056
    }
    proc _get_script_wm {tok} {
        variable _wm_script_msgs
        return $_wm_script_msgs($tok)
    }
}

# Backward compatibility aliases
interp alias {} twapi::GetWindowLong {} twapi::GetWindowLongPtr
interp alias {} twapi::SetWindowLong {} twapi::SetWindowLongPtr

# Return the long value at the given index
# This is a raw function, and should generally be used only to get
# non-system defined indices
proc twapi::get_window_long {hwin index} {
    return [GetWindowLongPtr $hwin $index]
}

# Set the long value at the given index and return the previous value
# This is a raw function, and should generally be used only to get
# non-system defined indices
proc twapi::set_window_long {hwin index val} {
    set oldval [SetWindowLongPtr $hwin $index $val]
}

# Set the user data associated with a window. Returns the previous value
proc twapi::set_window_userdata {hwin val} {
    # GWL_USERDATA -> -21
    return [SetWindowLongPtr $hwin -21 $val]
}

# Attaches to the thread queue of the thread owning $hwin and executes
# script in the caller's scope
proc twapi::_attach_hwin_and_eval {hwin script} {
    set me [GetCurrentThreadId]
    set hwin_tid [lindex [GetWindowThreadProcessId $hwin] 0]
    if {$hwin_tid == 0} {
        error "Window $hwin does not exist or could not get its thread owner"
    }

    # Cannot (and no need to) attach to oneself so just exec script directly
    if {$me == $hwin_tid} {
        return [uplevel 1 $script]
    }

    trap {
        if {![AttachThreadInput $me $hwin_tid 1]} {
            error "Could not attach to thread input for window $hwin"
        }
        set result [uplevel 1 $script]
    } finally {
        AttachThreadInput $me $hwin_tid 0
    }

    return $result
}

proc twapi::_register_script_wm_handler {msg cmdprefix {overwrite 0}} {
    variable _wm_registrations

    # Ensure notification window exists
    twapi::Twapi_GetNotificationWindow

    # The incr ensures decimal format
    # The lrange ensure proper list format
    if {$overwrite} {
        set _wm_registrations([incr msg 0]) [list [lrange $cmdprefix 0 end]]
    } else {
        lappend _wm_registrations([incr msg 0]) [lrange $cmdprefix 0 end]
    }
}

proc twapi::_unregister_script_wm_handler {msg cmdprefix} {
    variable _wm_registrations

    # The incr ensures decimal format
    incr msg 0
    # The lrange ensure proper list format
    if {[info exists _wm_registrations($msg)]} {
        set _wm_registrations($msg) [lsearch -exact -inline -not -all $_wm_registrations($msg) [lrange $cmdprefix 0 end]]
    }                                 
}

# Handles notifications from the common window for script level windows
# messages (see win.c)
proc twapi::_script_wm_handler {msg wparam lparam msgpos ticks} {
    variable _wm_registrations

    set code 0
    if {[info exists _wm_registrations($msg)]} {
        foreach handler $_wm_registrations($msg) {
            set code [catch {uplevel #0 [linsert $handler end $msg $wparam $lparam $msgpos $ticks]} msg]
            switch -exact -- $code {
                1 {
                    # TBD - should remaining handlers be called even on error ?
                    after 0 [list error $msg $::errorInfo $::errorCode]
                    break
                }
                3 {
                    break;      # Ignore remaining handlers
                }
                default {
                    # Keep going
                }
            }
        }
    } else {
        # TBD - debuglog - no handler for $msg
    }

    return
}