audiostuff: intercom/intercom.tcl comparison

comparison intercom/intercom.tcl @ 2:13be24d74cd2

import intercom-0.4.1

author	Peter Meerwald <pmeerw@cosy.sbg.ac.at>
date	Fri, 25 Jun 2010 09:57:52 +0200
parents
children

comparison

equal deleted inserted replaced

-:9cadc470e3da
+:13be24d74cd2
+#!/usr/bin/wish
+# intercom.tcl
+#
+# Copyright (C) DFS Deutsche Flugsicherung (2004, 2005).
+# All Rights Reserved.
+# Author: Andre Adrian
+#
+# Voice-over-IP Intercom Graphical User Interface
+#
+# Version 0.3.7
+# open all UDP sockets before use to fix problem with slow CPUs
+# UDP "connection" extension for Tcl/Tk
+load /usr/local/lib/libudp1.0.6.so
+# ##############################################################
+# Begin Belegt [IS_30] und Umleitung [IS_41] Remote Signallisierung
+# intercom.tcl to other intercom.tcl Signalling Receive init
+proc rsig_recv_init {port} {
+set srv [udp_open $port]
+fconfigure $srv -buffering none -translation binary
+fileevent $srv readable [list ::rsig_recv $srv]
+# puts "Listening on udp port: [fconfigure $srv -myport]"
+return $srv
+}
+# intercom.tcl to other intercom.tcl Signalling Send init
+proc rsig_send_init {host} {
+global rsig_send_sock
+set s [udp_open]
+fconfigure $s -remote [list $host 55004]
+set rsig_send_sock($host) $s
+}
+# intercom.tcl to other intercom.tcl Signalling Send
+proc rsig_puts {host str} {
+global rsig_send_sock
+puts $rsig_send_sock($host) $str
+flush $rsig_send_sock($host)
+}
+# intercom.tcl from other intercom.tcl Signalling Receive
+proc rsig_recv {sock} {
+global ip2tmap tping
+global t_updown umltgmap myipaddr
+set msg_body [read $sock]
+set msg_header [fconfigure $sock -peer]
+# puts "udp_server: $msg_header: [string length $msg_body] {$msg_body}"
+# to partner is first argument in msg_body
+set argv [split $msg_body]
+set ip_to [lindex $argv 1]
+set t_to $ip2tmap($ip_to)
+# from partner is taken from msg_header
+set conn [lindex $msg_header 0]
+set ip_from [lindex $conn 0]
+set t_from $ip2tmap($ip_from)
+switch [lindex $argv 0] {
+p {rsig_puts $ip_from "q $ip_to"   ;# got application ping
+}
+q {set tping ""   ;# got application ping response (pong)
+}
+c {.$t_from configure -highlightbackground cyan   ;# got call setup
+incr t_updown($t_from)
+.$t_to configure -highlightbackground cyan
+incr t_updown($t_to)
+}
+h {incr t_updown($t_from) -1    ;# got hangup
+if {$t_updown($t_from) <= 0} {
+set t_updown($t_from) 0
+.$t_from configure -highlightbackground "#d9d9d9"
+}
+incr t_updown($t_to) -1
+if {$t_updown($t_to) <= 0} {
+set t_updown($t_to) 0
+.$t_to configure -highlightbackground "#d9d9d9"
+}
+}
+d { # puts "rsig_recv ip_from=$ip_from ip_to=$ip_to"
+set umltgmap($ip_from) $ip_to   ;# got diversion
+# foreach i {1 2 3 4 5 6 7 8} {
+#   puts "umltgmap(10.232.35.$i) = $umltgmap(10.232.35.$i)"
+# }
+}
+default {puts "rsig_recv unknown msg=$msg_body"}
+}
+return
+}
+# End Belegt [IS_30] und Umleitung [IS_41] Remote Signallisierung
+# ##############################################################
+# Begin Stoerung Signalisierung [IS_31]
+proc checkping {} {
+global tping
+#puts "checkping $tping"
+if {$tping != ""} {
+.$tping configure -background red
+.$tping configure -activebackground red
+.$tping configure -highlightbackground red
+}
+}
+# End Stoerung Signalisierung [IS_31]
+# ##############################################################
+# Direct Access Button
+# View relevant function Arbeiter
+proc da_update {t state} {
+switch $state {
+0 { .$t configure -foreground black         ;# nothing
+.$t configure -activeforeground black
+.$t configure -background "#d9d9d9"     ;# button is grey
+.$t configure -activebackground "#d9d9d9"}
+1 { .$t configure -foreground black         ;# transmit
+.$t configure -activeforeground black
+.$t configure -background yellow
+.$t configure -activebackground yellow}
+2 { .$t configure -foreground black         ;# receive
+.$t configure -activeforeground black
+.$t configure -background magenta
+.$t configure -activebackground magenta}
+3 { .$t configure -foreground black         ;# full duplex
+.$t configure -activeforeground black
+.$t configure -background green
+.$t configure -activebackground green}
+}
+}
+# View relevant function Vorarbeiter
+proc da_ca_update {t state} {
+global ta_ip ip2tmap
+# update DA button
+da_update $t $state
+if {[info exists ip2tmap($ta_ip)]} {
+set t_alias $ip2tmap($ta_ip)
+} else {
+set t_alias ""
+}
+# Update Common Answer Button
+if { $t_alias == $t } {
+da_update ta $state
+}
+}
+# DA/CA button press callback
+proc da_keyPress {t} {
+global t2ipmap state lsig_sock longKey tping umltgmap ip2tmap
+set longKey($t) 0   ;# 1 wenn Taste lange gedr�ckt, sonst 0
+set ip $t2ipmap($t) ;# ip des remote intercom.tcl
+set uip $umltgmap($ip) ;# Umleitung auf gleiche IP oder andere IP
+# avoid two connections to one partner in case of diversion
+if {$ip != $uip} {
+if {$state($t) == 0 || $state($t) == 2} {
+set tumltg $ip2tmap($uip)
+if {$state($tumltg) == 1 || $state($tumltg) == 3} {
+puts "da_keyPress: error: already connection to this partner"
+return
+}
+}
+}
+# remote signalling
+switch $state($t) {
+0 {set cmd c
+after 300 [list set longKey($t) 1]
+rsig_puts $uip "p $uip"  ;# send application ping
+set tping $t
+after 200 [list checkping]}
+1 {set cmd h}
+2 {set cmd c
+after 300 [list set longKey($t) 1]
+rsig_puts $uip "p $uip"  ;# send application ping
+set tping $t
+after 200 [list checkping]}
+3 {set cmd h}
+}
+# local signalling to intercomd - maybe with diversion
+puts $lsig_sock "$cmd $uip"
+flush $lsig_sock
+# local signalling intercom.tcl - with no diversion
+switch $cmd {
+c {tx_begin $ip}
+r {rx_begin $ip}
+h {tx_end $ip}
+d {rx_end $ip}
+}
+# Begin Belegt Signalisierung [IS_30]
+foreach i {t1 t2 t3 t4 t5 t6 t7 t8} {
+set da_ip $t2ipmap($i)
+rsig_puts $da_ip "$cmd $uip"
+}
+# End Belegt Signalisierung [IS_30]
+}
+# DA/CA button release callback
+proc da_keyRelease {t} {
+global longKey
+if {$longKey($t)} {
+keyPress $t
+}
+}
+# ##############################################################
+# Common Answer Button Req IS_14
+proc ca_update {} {
+global ta_ip textmap
+# puts "ca_update $ta_ip"
+if {[info exists textmap($ta_ip)]} {
+set ta_text $textmap($ta_ip)
+} else {
+set ta_text $ta_ip
+}
+.ta configure -text $ta_text
+}
+# ##############################################################
+# Diversion (Umleitung) Req. IS_41
+# Update Umleitungstaste Req. IS_41
+proc umltg_update {} {
+global umltg_state tu_ip ip2tmap
+if {[info exists tu_ip]} {
+set told $ip2tmap($tu_ip)
+.$told configure -background "#d9d9d9"
+.$told configure -activebackground "#d9d9d9"
+}
+switch $umltg_state {
+0 { .tu configure -background "#d9d9d9"
+.tu configure -activebackground "#d9d9d9"
+.tu configure -text ""
+}
+1 { .tu configure -background orange
+.tu configure -activebackground orange
+}
+}
+}
+# Diversion Button callback
+proc umltg_keyRelease {} {
+global umltg_state myipaddr t2ipmap
+switch $umltg_state {
+0 {set umltg_state 1}
+1 {set umltg_state 0
+# Diversion release == Diversion to myipaddr
+foreach i {t1 t2 t3 t4 t5 t6 t7 t8} {
+set da_ip $t2ipmap($i)
+rsig_puts $da_ip "d $myipaddr"
+}
+}
+}
+umltg_update
+}
+# Direct Access Buttons callback
+proc umltg_da_keyRelease {t} {
+global t2ipmap textmap tu_ip ip2tmap myipaddr umltg_state
+# alten Zustand deaktivieren und updaten
+umltg_update
+# Model variable �ndern
+set tu_ip $t2ipmap($t)
+# neuen Zustand updaten
+.$t configure -background orange
+.$t configure -activebackground orange
+set tu_text $textmap($tu_ip)
+.tu configure -text $tu_text
+# Begin Umleitung Signalisierung [IS_41]
+foreach i {t1 t2 t3 t4 t5 t6 t7 t8} {
+set da_ip $t2ipmap($i)
+rsig_puts $da_ip "d $tu_ip"
+}
+# End Umleitung Signalisierung [IS_41]
+}
+# ##############################################################
+# Direct Access / Diversion Buttons Callbacks
+proc keyPress {t} {
+global umltg_state
+switch $umltg_state {
+0 {da_keyPress $t}
+1 {}
+}
+}
+proc keyRelease {t} {
+global umltg_state told
+switch $umltg_state {
+0 {da_keyRelease $t}
+1 {umltg_da_keyRelease $t}
+}
+}
+# ##############################################################
+# Direct Access model relevant function
+proc tx_begin {ip} {
+global ip2tmap state
+set t $ip2tmap($ip)
+#puts "tx_begin $ip $t"
+switch $state($t) {
+0 {set state($t) 1}
+1 { }
+2 {set state($t) 3}
+3 { }
+}
+da_ca_update $t $state($t)
+}
+proc rx_begin {ip} {
+global ip2tmap state
+set t $ip2tmap($ip)
+#puts "rx_begin $ip $t"
+switch $state($t) {
+0 {set state($t) 2}
+1 {set state($t) 3}
+2 { }
+3 { }
+}
+# Answer Button Req IS_14
+global ta_ip
+set ta_ip $ip
+ca_update
+.ta configure -command [list keyRelease $t]
+bind .ta <ButtonPress-1> [list keyPress $t]
+# End Answer Button Req IS_14
+da_ca_update $t $state($t)
+}
+proc tx_end {ip} {
+global ip2tmap state
+set t $ip2tmap($ip)
+#puts "tx_end $ip $t"
+switch $state($t) {
+0 {}
+1 {set state($t) 0}
+2 { }
+3 {set state($t) 2}
+}
+da_ca_update $t $state($t)
+}
+proc rx_end {ip} {
+global ip2tmap state
+set t $ip2tmap($ip)
+#puts "rx_end $ip $t"
+switch $state($t) {
+0 { }
+1 { }
+2 {set state($t) 0}
+3 {set state($t) 1}
+}
+da_ca_update $t $state($t)
+}
+# ##############################################################
+# Local Signalling
+# intercom.tcl from own intercomd Signalling Receive
+proc lsig_recv {} {
+global lsig_sock
+gets $lsig_sock cmd
+# puts "lsig_recv $cmd"
+set argv [split $cmd]
+# puts $argv
+set ip [lindex $argv 1]
+switch [lindex $argv 0] {
+c {tx_begin $ip}
+r {rx_begin $ip}
+h {tx_end $ip}
+d {rx_end $ip}
+}
+}
+# ##############################################################
+# Program exit (abort, close) Handler
+proc onDestroy {} {
+global destroyflag lsig_sock rsig_recv_sock
+if {$destroyflag == 0} {
+set destroyflag 1
+puts "Terminate intercomd and intercom"
+close $lsig_sock
+close $rsig_recv_sock
+exec /usr/bin/killall -9 /usr/local/bin/intercomd \
+/usr/local/bin/intercomd1
+}
+}
+# ##############################################################
+# Read configuration file - hack just use Tcl/Tk parser
+proc guiconfig {t text ip} {
+global state longKey ip2tmap t2ipmap umltgmap
+set state($t) 0
+set longKey($t) 0
+rsig_send_init $ip
+set ip2tmap($ip) $t
+set t2ipmap($t) $ip
+set umltgmap($ip) $ip   ;# keine Umleitung
+.$t configure -text $text
+.$t configure -command [list keyRelease $t]
+bind .$t <ButtonPress-1> [list keyPress $t]
+# Answer Button Req IS_14
+global textmap
+set textmap($ip) $text
+da_ca_update $t $state($t)
+}
+# ##############################################################
+# Begin main
+# init and register programm termination handler
+set destroyflag 0
+bind . <Destroy> [list onDestroy]
+# include GUI
+source /usr/local/bin/intercom.ui.tcl
+intercom_ui .
+# init model
+foreach {i} {t1 t2 t3 t4 t5 t6 t7 t8} {
+set t_updown($i) 0
+}
+# init view
+foreach {i} {t1 t2 t3 t4 t5 t6 t7 t8 ta tu} {
+.$i configure -width 5 -height 2 -highlightthickness 12
+}
+# init Common Answer-Button Req. IS_14
+set ta_ip ""
+# init and register Diversion Req. IS_41
+set umltg_state 0
+.tu configure -command [list umltg_keyRelease]
+# include configuration
+if {[file exists ~/.intercom.conf]} {
+source ~/.intercom.conf
+} else {
+file copy /usr/local/bin/intercom.conf ~/.intercom.conf
+puts ""
+puts "Please edit the file ~/.intercom.conf for your Labels and your"
+puts "IP-addresses. Then start intercom again."
+exit
+}
+# init local signalling to intercomd, a TCP connection
+set lsig_sock [socket 127.0.0.1 4999]
+fileevent $lsig_sock readable lsig_recv
+# init remote signalling to intercom.tcl, an UDP "connection"
+set rsig_recv_sock [rsig_recv_init 55004]
+# set window title
+set nodename [exec uname -n]
+wm title . "intercom $nodename"
+# hack: get my ip address
+set hostsline [exec grep $nodename /etc/hosts]
+set myipaddr [lindex [split $hostsline] 0]
+# End main
+# ##############################################################

Mercurial > hg > audiostuff

comparison intercom/intercom.tcl @ 2:13be24d74cd2