|
2
|
1 #!/usr/bin/wish
|
|
|
2
|
|
|
3 # intercom.tcl
|
|
|
4 #
|
|
|
5 # Copyright (C) DFS Deutsche Flugsicherung (2004, 2005).
|
|
|
6 # All Rights Reserved.
|
|
|
7 # Author: Andre Adrian
|
|
|
8 #
|
|
|
9 # Voice-over-IP Intercom Graphical User Interface
|
|
|
10 #
|
|
|
11 # Version 0.3.7
|
|
|
12 # open all UDP sockets before use to fix problem with slow CPUs
|
|
|
13
|
|
|
14
|
|
|
15 # UDP "connection" extension for Tcl/Tk
|
|
|
16 load /usr/local/lib/libudp1.0.6.so
|
|
|
17
|
|
|
18 # ##############################################################
|
|
|
19 # Begin Belegt [IS_30] und Umleitung [IS_41] Remote Signallisierung
|
|
|
20
|
|
|
21 # intercom.tcl to other intercom.tcl Signalling Receive init
|
|
|
22 proc rsig_recv_init {port} {
|
|
|
23 set srv [udp_open $port]
|
|
|
24 fconfigure $srv -buffering none -translation binary
|
|
|
25 fileevent $srv readable [list ::rsig_recv $srv]
|
|
|
26 # puts "Listening on udp port: [fconfigure $srv -myport]"
|
|
|
27 return $srv
|
|
|
28 }
|
|
|
29
|
|
|
30 # intercom.tcl to other intercom.tcl Signalling Send init
|
|
|
31 proc rsig_send_init {host} {
|
|
|
32 global rsig_send_sock
|
|
|
33
|
|
|
34 set s [udp_open]
|
|
|
35 fconfigure $s -remote [list $host 55004]
|
|
|
36 set rsig_send_sock($host) $s
|
|
|
37 }
|
|
|
38
|
|
|
39 # intercom.tcl to other intercom.tcl Signalling Send
|
|
|
40 proc rsig_puts {host str} {
|
|
|
41 global rsig_send_sock
|
|
|
42
|
|
|
43 puts $rsig_send_sock($host) $str
|
|
|
44 flush $rsig_send_sock($host)
|
|
|
45 }
|
|
|
46
|
|
|
47 # intercom.tcl from other intercom.tcl Signalling Receive
|
|
|
48 proc rsig_recv {sock} {
|
|
|
49 global ip2tmap tping
|
|
|
50 global t_updown umltgmap myipaddr
|
|
|
51
|
|
|
52 set msg_body [read $sock]
|
|
|
53 set msg_header [fconfigure $sock -peer]
|
|
|
54 # puts "udp_server: $msg_header: [string length $msg_body] {$msg_body}"
|
|
|
55
|
|
|
56 # to partner is first argument in msg_body
|
|
|
57 set argv [split $msg_body]
|
|
|
58 set ip_to [lindex $argv 1]
|
|
|
59 set t_to $ip2tmap($ip_to)
|
|
|
60
|
|
|
61 # from partner is taken from msg_header
|
|
|
62 set conn [lindex $msg_header 0]
|
|
|
63 set ip_from [lindex $conn 0]
|
|
|
64 set t_from $ip2tmap($ip_from)
|
|
|
65
|
|
|
66 switch [lindex $argv 0] {
|
|
|
67 p {rsig_puts $ip_from "q $ip_to" ;# got application ping
|
|
|
68 }
|
|
|
69 q {set tping "" ;# got application ping response (pong)
|
|
|
70 }
|
|
|
71 c {.$t_from configure -highlightbackground cyan ;# got call setup
|
|
|
72 incr t_updown($t_from)
|
|
|
73 .$t_to configure -highlightbackground cyan
|
|
|
74 incr t_updown($t_to)
|
|
|
75 }
|
|
|
76 h {incr t_updown($t_from) -1 ;# got hangup
|
|
|
77 if {$t_updown($t_from) <= 0} {
|
|
|
78 set t_updown($t_from) 0
|
|
|
79 .$t_from configure -highlightbackground "#d9d9d9"
|
|
|
80 }
|
|
|
81 incr t_updown($t_to) -1
|
|
|
82 if {$t_updown($t_to) <= 0} {
|
|
|
83 set t_updown($t_to) 0
|
|
|
84 .$t_to configure -highlightbackground "#d9d9d9"
|
|
|
85 }
|
|
|
86 }
|
|
|
87 d { # puts "rsig_recv ip_from=$ip_from ip_to=$ip_to"
|
|
|
88 set umltgmap($ip_from) $ip_to ;# got diversion
|
|
|
89 # foreach i {1 2 3 4 5 6 7 8} {
|
|
|
90 # puts "umltgmap(10.232.35.$i) = $umltgmap(10.232.35.$i)"
|
|
|
91 # }
|
|
|
92 }
|
|
|
93 default {puts "rsig_recv unknown msg=$msg_body"}
|
|
|
94 }
|
|
|
95 return
|
|
|
96 }
|
|
|
97
|
|
|
98 # End Belegt [IS_30] und Umleitung [IS_41] Remote Signallisierung
|
|
|
99
|
|
|
100 # ##############################################################
|
|
|
101 # Begin Stoerung Signalisierung [IS_31]
|
|
|
102
|
|
|
103 proc checkping {} {
|
|
|
104 global tping
|
|
|
105
|
|
|
106 #puts "checkping $tping"
|
|
|
107 if {$tping != ""} {
|
|
|
108 .$tping configure -background red
|
|
|
109 .$tping configure -activebackground red
|
|
|
110 .$tping configure -highlightbackground red
|
|
|
111 }
|
|
|
112 }
|
|
|
113 # End Stoerung Signalisierung [IS_31]
|
|
|
114
|
|
|
115 # ##############################################################
|
|
|
116 # Direct Access Button
|
|
|
117
|
|
|
118 # View relevant function Arbeiter
|
|
|
119 proc da_update {t state} {
|
|
|
120 switch $state {
|
|
|
121 0 { .$t configure -foreground black ;# nothing
|
|
|
122 .$t configure -activeforeground black
|
|
|
123 .$t configure -background "#d9d9d9" ;# button is grey
|
|
|
124 .$t configure -activebackground "#d9d9d9"}
|
|
|
125 1 { .$t configure -foreground black ;# transmit
|
|
|
126 .$t configure -activeforeground black
|
|
|
127 .$t configure -background yellow
|
|
|
128 .$t configure -activebackground yellow}
|
|
|
129 2 { .$t configure -foreground black ;# receive
|
|
|
130 .$t configure -activeforeground black
|
|
|
131 .$t configure -background magenta
|
|
|
132 .$t configure -activebackground magenta}
|
|
|
133 3 { .$t configure -foreground black ;# full duplex
|
|
|
134 .$t configure -activeforeground black
|
|
|
135 .$t configure -background green
|
|
|
136 .$t configure -activebackground green}
|
|
|
137 }
|
|
|
138 }
|
|
|
139
|
|
|
140 # View relevant function Vorarbeiter
|
|
|
141 proc da_ca_update {t state} {
|
|
|
142 global ta_ip ip2tmap
|
|
|
143
|
|
|
144 # update DA button
|
|
|
145 da_update $t $state
|
|
|
146
|
|
|
147 if {[info exists ip2tmap($ta_ip)]} {
|
|
|
148 set t_alias $ip2tmap($ta_ip)
|
|
|
149 } else {
|
|
|
150 set t_alias ""
|
|
|
151 }
|
|
|
152
|
|
|
153 # Update Common Answer Button
|
|
|
154 if { $t_alias == $t } {
|
|
|
155 da_update ta $state
|
|
|
156 }
|
|
|
157 }
|
|
|
158
|
|
|
159 # DA/CA button press callback
|
|
|
160 proc da_keyPress {t} {
|
|
|
161 global t2ipmap state lsig_sock longKey tping umltgmap ip2tmap
|
|
|
162
|
|
|
163 set longKey($t) 0 ;# 1 wenn Taste lange gedrückt, sonst 0
|
|
|
164 set ip $t2ipmap($t) ;# ip des remote intercom.tcl
|
|
|
165 set uip $umltgmap($ip) ;# Umleitung auf gleiche IP oder andere IP
|
|
|
166
|
|
|
167 # avoid two connections to one partner in case of diversion
|
|
|
168 if {$ip != $uip} {
|
|
|
169 if {$state($t) == 0 || $state($t) == 2} {
|
|
|
170 set tumltg $ip2tmap($uip)
|
|
|
171 if {$state($tumltg) == 1 || $state($tumltg) == 3} {
|
|
|
172 puts "da_keyPress: error: already connection to this partner"
|
|
|
173 return
|
|
|
174 }
|
|
|
175 }
|
|
|
176 }
|
|
|
177
|
|
|
178 # remote signalling
|
|
|
179 switch $state($t) {
|
|
|
180 0 {set cmd c
|
|
|
181 after 300 [list set longKey($t) 1]
|
|
|
182 rsig_puts $uip "p $uip" ;# send application ping
|
|
|
183 set tping $t
|
|
|
184 after 200 [list checkping]}
|
|
|
185 1 {set cmd h}
|
|
|
186 2 {set cmd c
|
|
|
187 after 300 [list set longKey($t) 1]
|
|
|
188 rsig_puts $uip "p $uip" ;# send application ping
|
|
|
189 set tping $t
|
|
|
190 after 200 [list checkping]}
|
|
|
191 3 {set cmd h}
|
|
|
192 }
|
|
|
193
|
|
|
194 # local signalling to intercomd - maybe with diversion
|
|
|
195 puts $lsig_sock "$cmd $uip"
|
|
|
196 flush $lsig_sock
|
|
|
197
|
|
|
198 # local signalling intercom.tcl - with no diversion
|
|
|
199 switch $cmd {
|
|
|
200 c {tx_begin $ip}
|
|
|
201 r {rx_begin $ip}
|
|
|
202 h {tx_end $ip}
|
|
|
203 d {rx_end $ip}
|
|
|
204 }
|
|
|
205
|
|
|
206 # Begin Belegt Signalisierung [IS_30]
|
|
|
207 foreach i {t1 t2 t3 t4 t5 t6 t7 t8} {
|
|
|
208 set da_ip $t2ipmap($i)
|
|
|
209 rsig_puts $da_ip "$cmd $uip"
|
|
|
210 }
|
|
|
211 # End Belegt Signalisierung [IS_30]
|
|
|
212 }
|
|
|
213
|
|
|
214 # DA/CA button release callback
|
|
|
215 proc da_keyRelease {t} {
|
|
|
216 global longKey
|
|
|
217
|
|
|
218 if {$longKey($t)} {
|
|
|
219 keyPress $t
|
|
|
220 }
|
|
|
221 }
|
|
|
222
|
|
|
223 # ##############################################################
|
|
|
224 # Common Answer Button Req IS_14
|
|
|
225
|
|
|
226 proc ca_update {} {
|
|
|
227 global ta_ip textmap
|
|
|
228
|
|
|
229 # puts "ca_update $ta_ip"
|
|
|
230
|
|
|
231 if {[info exists textmap($ta_ip)]} {
|
|
|
232 set ta_text $textmap($ta_ip)
|
|
|
233 } else {
|
|
|
234 set ta_text $ta_ip
|
|
|
235 }
|
|
|
236 .ta configure -text $ta_text
|
|
|
237 }
|
|
|
238
|
|
|
239 # ##############################################################
|
|
|
240 # Diversion (Umleitung) Req. IS_41
|
|
|
241
|
|
|
242 # Update Umleitungstaste Req. IS_41
|
|
|
243 proc umltg_update {} {
|
|
|
244 global umltg_state tu_ip ip2tmap
|
|
|
245
|
|
|
246 if {[info exists tu_ip]} {
|
|
|
247 set told $ip2tmap($tu_ip)
|
|
|
248 .$told configure -background "#d9d9d9"
|
|
|
249 .$told configure -activebackground "#d9d9d9"
|
|
|
250 }
|
|
|
251 switch $umltg_state {
|
|
|
252 0 { .tu configure -background "#d9d9d9"
|
|
|
253 .tu configure -activebackground "#d9d9d9"
|
|
|
254 .tu configure -text ""
|
|
|
255 }
|
|
|
256 1 { .tu configure -background orange
|
|
|
257 .tu configure -activebackground orange
|
|
|
258 }
|
|
|
259 }
|
|
|
260 }
|
|
|
261
|
|
|
262 # Diversion Button callback
|
|
|
263 proc umltg_keyRelease {} {
|
|
|
264 global umltg_state myipaddr t2ipmap
|
|
|
265
|
|
|
266 switch $umltg_state {
|
|
|
267 0 {set umltg_state 1}
|
|
|
268 1 {set umltg_state 0
|
|
|
269 # Diversion release == Diversion to myipaddr
|
|
|
270 foreach i {t1 t2 t3 t4 t5 t6 t7 t8} {
|
|
|
271 set da_ip $t2ipmap($i)
|
|
|
272 rsig_puts $da_ip "d $myipaddr"
|
|
|
273 }
|
|
|
274 }
|
|
|
275 }
|
|
|
276 umltg_update
|
|
|
277 }
|
|
|
278
|
|
|
279 # Direct Access Buttons callback
|
|
|
280 proc umltg_da_keyRelease {t} {
|
|
|
281 global t2ipmap textmap tu_ip ip2tmap myipaddr umltg_state
|
|
|
282
|
|
|
283 # alten Zustand deaktivieren und updaten
|
|
|
284 umltg_update
|
|
|
285
|
|
|
286 # Model variable ändern
|
|
|
287 set tu_ip $t2ipmap($t)
|
|
|
288
|
|
|
289 # neuen Zustand updaten
|
|
|
290 .$t configure -background orange
|
|
|
291 .$t configure -activebackground orange
|
|
|
292 set tu_text $textmap($tu_ip)
|
|
|
293 .tu configure -text $tu_text
|
|
|
294
|
|
|
295 # Begin Umleitung Signalisierung [IS_41]
|
|
|
296 foreach i {t1 t2 t3 t4 t5 t6 t7 t8} {
|
|
|
297 set da_ip $t2ipmap($i)
|
|
|
298 rsig_puts $da_ip "d $tu_ip"
|
|
|
299 }
|
|
|
300 # End Umleitung Signalisierung [IS_41]
|
|
|
301 }
|
|
|
302
|
|
|
303 # ##############################################################
|
|
|
304 # Direct Access / Diversion Buttons Callbacks
|
|
|
305
|
|
|
306 proc keyPress {t} {
|
|
|
307 global umltg_state
|
|
|
308
|
|
|
309 switch $umltg_state {
|
|
|
310 0 {da_keyPress $t}
|
|
|
311 1 {}
|
|
|
312 }
|
|
|
313 }
|
|
|
314
|
|
|
315 proc keyRelease {t} {
|
|
|
316 global umltg_state told
|
|
|
317
|
|
|
318 switch $umltg_state {
|
|
|
319 0 {da_keyRelease $t}
|
|
|
320 1 {umltg_da_keyRelease $t}
|
|
|
321 }
|
|
|
322 }
|
|
|
323
|
|
|
324 # ##############################################################
|
|
|
325 # Direct Access model relevant function
|
|
|
326
|
|
|
327 proc tx_begin {ip} {
|
|
|
328 global ip2tmap state
|
|
|
329
|
|
|
330 set t $ip2tmap($ip)
|
|
|
331 #puts "tx_begin $ip $t"
|
|
|
332 switch $state($t) {
|
|
|
333 0 {set state($t) 1}
|
|
|
334 1 { }
|
|
|
335 2 {set state($t) 3}
|
|
|
336 3 { }
|
|
|
337 }
|
|
|
338 da_ca_update $t $state($t)
|
|
|
339 }
|
|
|
340
|
|
|
341 proc rx_begin {ip} {
|
|
|
342 global ip2tmap state
|
|
|
343
|
|
|
344 set t $ip2tmap($ip)
|
|
|
345 #puts "rx_begin $ip $t"
|
|
|
346 switch $state($t) {
|
|
|
347 0 {set state($t) 2}
|
|
|
348 1 {set state($t) 3}
|
|
|
349 2 { }
|
|
|
350 3 { }
|
|
|
351 }
|
|
|
352
|
|
|
353 # Answer Button Req IS_14
|
|
|
354 global ta_ip
|
|
|
355
|
|
|
356 set ta_ip $ip
|
|
|
357 ca_update
|
|
|
358
|
|
|
359 .ta configure -command [list keyRelease $t]
|
|
|
360 bind .ta <ButtonPress-1> [list keyPress $t]
|
|
|
361 # End Answer Button Req IS_14
|
|
|
362
|
|
|
363 da_ca_update $t $state($t)
|
|
|
364 }
|
|
|
365
|
|
|
366 proc tx_end {ip} {
|
|
|
367 global ip2tmap state
|
|
|
368
|
|
|
369 set t $ip2tmap($ip)
|
|
|
370 #puts "tx_end $ip $t"
|
|
|
371 switch $state($t) {
|
|
|
372 0 {}
|
|
|
373 1 {set state($t) 0}
|
|
|
374 2 { }
|
|
|
375 3 {set state($t) 2}
|
|
|
376 }
|
|
|
377 da_ca_update $t $state($t)
|
|
|
378 }
|
|
|
379
|
|
|
380 proc rx_end {ip} {
|
|
|
381 global ip2tmap state
|
|
|
382
|
|
|
383 set t $ip2tmap($ip)
|
|
|
384 #puts "rx_end $ip $t"
|
|
|
385 switch $state($t) {
|
|
|
386 0 { }
|
|
|
387 1 { }
|
|
|
388 2 {set state($t) 0}
|
|
|
389 3 {set state($t) 1}
|
|
|
390 }
|
|
|
391 da_ca_update $t $state($t)
|
|
|
392 }
|
|
|
393
|
|
|
394 # ##############################################################
|
|
|
395 # Local Signalling
|
|
|
396
|
|
|
397 # intercom.tcl from own intercomd Signalling Receive
|
|
|
398 proc lsig_recv {} {
|
|
|
399 global lsig_sock
|
|
|
400
|
|
|
401 gets $lsig_sock cmd
|
|
|
402 # puts "lsig_recv $cmd"
|
|
|
403 set argv [split $cmd]
|
|
|
404 # puts $argv
|
|
|
405 set ip [lindex $argv 1]
|
|
|
406 switch [lindex $argv 0] {
|
|
|
407 c {tx_begin $ip}
|
|
|
408 r {rx_begin $ip}
|
|
|
409 h {tx_end $ip}
|
|
|
410 d {rx_end $ip}
|
|
|
411 }
|
|
|
412 }
|
|
|
413
|
|
|
414 # ##############################################################
|
|
|
415 # Program exit (abort, close) Handler
|
|
|
416
|
|
|
417 proc onDestroy {} {
|
|
|
418 global destroyflag lsig_sock rsig_recv_sock
|
|
|
419
|
|
|
420 if {$destroyflag == 0} {
|
|
|
421 set destroyflag 1
|
|
|
422 puts "Terminate intercomd and intercom"
|
|
|
423 close $lsig_sock
|
|
|
424 close $rsig_recv_sock
|
|
|
425 exec /usr/bin/killall -9 /usr/local/bin/intercomd \
|
|
|
426 /usr/local/bin/intercomd1
|
|
|
427 }
|
|
|
428 }
|
|
|
429
|
|
|
430 # ##############################################################
|
|
|
431 # Read configuration file - hack just use Tcl/Tk parser
|
|
|
432
|
|
|
433 proc guiconfig {t text ip} {
|
|
|
434 global state longKey ip2tmap t2ipmap umltgmap
|
|
|
435
|
|
|
436 set state($t) 0
|
|
|
437 set longKey($t) 0
|
|
|
438
|
|
|
439 rsig_send_init $ip
|
|
|
440
|
|
|
441 set ip2tmap($ip) $t
|
|
|
442 set t2ipmap($t) $ip
|
|
|
443
|
|
|
444 set umltgmap($ip) $ip ;# keine Umleitung
|
|
|
445
|
|
|
446 .$t configure -text $text
|
|
|
447 .$t configure -command [list keyRelease $t]
|
|
|
448 bind .$t <ButtonPress-1> [list keyPress $t]
|
|
|
449
|
|
|
450 # Answer Button Req IS_14
|
|
|
451 global textmap
|
|
|
452
|
|
|
453 set textmap($ip) $text
|
|
|
454
|
|
|
455 da_ca_update $t $state($t)
|
|
|
456 }
|
|
|
457
|
|
|
458 # ##############################################################
|
|
|
459 # Begin main
|
|
|
460
|
|
|
461 # init and register programm termination handler
|
|
|
462 set destroyflag 0
|
|
|
463 bind . <Destroy> [list onDestroy]
|
|
|
464
|
|
|
465 # include GUI
|
|
|
466 source /usr/local/bin/intercom.ui.tcl
|
|
|
467 intercom_ui .
|
|
|
468
|
|
|
469 # init model
|
|
|
470 foreach {i} {t1 t2 t3 t4 t5 t6 t7 t8} {
|
|
|
471 set t_updown($i) 0
|
|
|
472 }
|
|
|
473
|
|
|
474 # init view
|
|
|
475 foreach {i} {t1 t2 t3 t4 t5 t6 t7 t8 ta tu} {
|
|
|
476 .$i configure -width 5 -height 2 -highlightthickness 12
|
|
|
477 }
|
|
|
478
|
|
|
479 # init Common Answer-Button Req. IS_14
|
|
|
480 set ta_ip ""
|
|
|
481
|
|
|
482 # init and register Diversion Req. IS_41
|
|
|
483 set umltg_state 0
|
|
|
484 .tu configure -command [list umltg_keyRelease]
|
|
|
485
|
|
|
486 # include configuration
|
|
|
487 if {[file exists ~/.intercom.conf]} {
|
|
|
488 source ~/.intercom.conf
|
|
|
489 } else {
|
|
|
490 file copy /usr/local/bin/intercom.conf ~/.intercom.conf
|
|
|
491 puts ""
|
|
|
492 puts "Please edit the file ~/.intercom.conf for your Labels and your"
|
|
|
493 puts "IP-addresses. Then start intercom again."
|
|
|
494 exit
|
|
|
495 }
|
|
|
496
|
|
|
497 # init local signalling to intercomd, a TCP connection
|
|
|
498 set lsig_sock [socket 127.0.0.1 4999]
|
|
|
499 fileevent $lsig_sock readable lsig_recv
|
|
|
500
|
|
|
501 # init remote signalling to intercom.tcl, an UDP "connection"
|
|
|
502 set rsig_recv_sock [rsig_recv_init 55004]
|
|
|
503
|
|
|
504 # set window title
|
|
|
505 set nodename [exec uname -n]
|
|
|
506 wm title . "intercom $nodename"
|
|
|
507
|
|
|
508 # hack: get my ip address
|
|
|
509 set hostsline [exec grep $nodename /etc/hosts]
|
|
|
510 set myipaddr [lindex [split $hostsline] 0]
|
|
|
511
|
|
|
512 # End main
|
|
|
513 # ##############################################################
|
