--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/intercom/intercom.tcl	Fri Jun 25 09:57:52 2010 +0200
@@ -0,0 +1,513 @@
+#!/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
+# ##############################################################