1#
2# Copyright (c) 2010, Ashok P. Nadkarni
3# All rights reserved.
4#
5# See the file LICENSE for license
6
7# Remote Desktop Services - TBD - document and test
8
9namespace eval twapi {}
10
11proc twapi::rds_enumerate_sessions {args} {
12    array set opts [parseargs args {
13        {hserver.arg 0}
14        state.arg
15    } -maxleftover 0]
16
17    set states {active connected connectquery shadow disconnected idle listen reset down init}
18    if {[info exists opts(state)]} {
19        if {[string is integer -strict $opts(state)]} {
20            set state $opts(state)
21        } else {
22            set state [lsearch -exact $states $opts(state)]
23            if {$state < 0} {
24                error "Invalid value '$opts(state)' specified for -state option."
25            }
26        }
27    }
28
29    set sessions [WTSEnumerateSessions $opts(hserver)]
30
31    if {[info exists state]} {
32        set sessions [recordarray get $sessions -filter [list [list State == $state]]]
33    }
34
35    set result {}
36    foreach {sess rec} [recordarray getdict $sessions -key SessionId -format dict] {
37        set state [lindex $states [kl_get $rec State]]
38        if {$state eq ""} {
39            set state [kl_get $rec State]
40        }
41        lappend result $sess [list -tssession [kl_get $rec SessionId] \
42                                  -winstaname [kl_get $rec pWinStationName] \
43                                  -state $state]
44    }
45    return $result
46}
47
48proc twapi::rds_disconnect_session args {
49    array set opts [parseargs args {
50        {hserver.arg 0}
51        {tssession.int -1}
52        {async.bool false}
53    } -maxleftover 0]
54
55    WTSDisconnectSession $opts(hserver) $opts(tssession) [expr {! $opts(async)}]
56
57}
58
59proc twapi::rds_logoff_session args {
60    array set opts [parseargs args {
61        {hserver.arg 0}
62        {tssession.int -1}
63        {async.bool false}
64    } -maxleftover 0]
65
66    WTSLogoffSession $opts(hserver) $opts(tssession) [expr {! $opts(async)}]
67}
68
69proc twapi::rds_query_session_information {infoclass args} {
70    array set opts [parseargs args {
71        {hserver.arg 0}
72        {tssession.int -1}
73    } -maxleftover 0]
74
75    return [WTSQuerySessionInformation $opts(hserver) $opts(tssession) $infoclass]
76}
77
78interp alias {} twapi::rds_get_session_appname {} twapi::rds_query_session_information 1
79interp alias {} twapi::rds_get_session_clientdir {} twapi::rds_query_session_information 11
80interp alias {} twapi::rds_get_session_clientname {} twapi::rds_query_session_information 10
81interp alias {} twapi::rds_get_session_userdomain {} twapi::rds_query_session_information 7
82interp alias {} twapi::rds_get_session_initialprogram {} twapi::rds_query_session_information 0
83interp alias {} twapi::rds_get_session_oemid {} twapi::rds_query_session_information 3
84interp alias {} twapi::rds_get_session_user {} twapi::rds_query_session_information 5
85interp alias {} twapi::rds_get_session_winsta {} twapi::rds_query_session_information 6
86interp alias {} twapi::rds_get_session_intialdir {} twapi::rds_query_session_information 2
87interp alias {} twapi::rds_get_session_clientbuild {} twapi::rds_query_session_information 9
88interp alias {} twapi::rds_get_session_clienthwid {} twapi::rds_query_session_information 13
89interp alias {} twapi::rds_get_session_state {} twapi::rds_query_session_information 8
90interp alias {} twapi::rds_get_session_id {} twapi::rds_query_session_information 4
91interp alias {} twapi::rds_get_session_productid {} twapi::rds_query_session_information 12
92interp alias {} twapi::rds_get_session_protocol {} twapi::rds_query_session_information 16
93
94
95proc twapi::rds_send_message {args} {
96
97    array set opts [parseargs args {
98        {hserver.arg 0}
99        tssession.int
100        title.arg
101        message.arg
102        {buttons.arg ok}
103        {icon.arg information}
104        defaultbutton.arg
105        {modality.arg task {task appl application system}}
106        {justify.arg left {left right}}
107        rtl.bool
108        foreground.bool
109        topmost.bool
110        showhelp.bool
111        service.bool
112        timeout.int
113        async.bool
114    } -maxleftover 0 -nulldefault]
115
116    if {![kl_vget {
117        ok             {0 {ok}}
118        okcancel       {1 {ok cancel}}
119        abortretryignore {2 {abort retry ignore}}
120        yesnocancel    {3 {yes no cancel}}
121        yesno          {4 {yes no}}
122        retrycancel    {5 {retry cancel}}
123        canceltrycontinue {6 {cancel try continue}}
124    } $opts(buttons) buttons]} {
125        error "Invalid value '$opts(buttons)' specified for option -buttons."
126    }
127
128    set style [lindex $buttons 0]
129    switch -exact -- $opts(icon) {
130        warning -
131        exclamation {setbits style 0x30}
132        asterisk -
133        information {setbits style 0x40}
134        question    {setbits style 0x20}
135        error -
136        hand  -
137        stop        {setbits style 0x10}
138        default {
139            error "Invalid value '$opts(icon)' specified for option -icon."
140        }
141    }
142
143    # Map the default button
144    switch -exact -- [lsearch -exact [lindex $buttons 1] $opts(defaultbutton)] {
145        1 {setbits style 0x100 }
146        2 {setbits style 0x200 }
147        3 {setbits style 0x300 }
148        default {
149            # First button,
150            # setbits style 0x000
151        }
152    }
153
154    switch -exact -- $opts(modality) {
155        system { setbits style 0x1000 }
156        task   { setbits style 0x2000 }
157        appl -
158        application -
159        default {
160            # setbits style 0x0000
161        }
162    }
163
164    if {$opts(showhelp)} { setbits style 0x00004000 }
165    if {$opts(rtl)} { setbits style 0x00100000 }
166    if {$opts(justify) eq "right"} { setbits style 0x00080000 }
167    if {$opts(topmost)} { setbits style 0x00040000 }
168    if {$opts(foreground)} { setbits style 0x00010000 }
169    if {$opts(service)} { setbits style 0x00200000 }
170
171    set response [WTSSendMessage $opts(hserver) $opts(tssession) $opts(title) \
172                      $opts(message) $style $opts(timeout) \
173                      [expr {!$opts(async)}]]
174
175    switch -exact -- $response {
176        1 { return ok }
177        2 { return cancel }
178        3 { return abort }
179        4 { return retry }
180        5 { return ignore }
181        6 { return yes }
182        7 { return no }
183        8 { return close }
184        9 { return help }
185        10 { return tryagain }
186        11 { return continue }
187        32000 { return timeout }
188        32001 { return async }
189        default { return $response }
190    }
191}
192