#!/bin/sh
# -*- tcl -*- \
    exec wish "$0" "$@"

# Copyright (C) 2001 Robert Fenk
#
# Author:      Robert Fenk
# X-URL:       http://www.robf.de/Hacking/TclTk.html
# X-RCS:       $Id: tkservice.tk,v 1.3 2003/04/28 19:39:13 fenk Exp $
#
# This code is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 1, or (at your option)
# any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

proc makeTerminal {{toplevel {}}} {
  if {[winfo exist $toplevel]} {
    set t $toplevel.log
    $t delete 1.0 end
    return $t
  }
  if {$toplevel != ""  && ![winfo exist $toplevel]} {
    toplevel $toplevel
  }
  set t $toplevel.log
  set s $toplevel.sb
  text $t -yscrollcommand "$s set"
  scrollbar $s -command "$t yview" -orient vertical
  pack $s -side right -fill y
  pack $t -expand 1 -fill both
  return $t
}

proc mess {message} {
  global log
  $log insert end "$message\n"
  $log see insert
}

proc log {message} {
  set time [clock format [clock seconds]]
  global log
  mess "$time: $message"
}

proc receive {sock} {
  log "Receiving from $sock"
  global widget
  set t $widget($sock)
  if {[eof $sock]} {
    close $sock
#    destroy [winfo toplevel $t]
    log "Socket $sock closed"
  } else {
    $t insert end "[gets $sock]\n"
    $t see insert
    update
  }
}

proc send {sock} {
  log "Sending to $sock"
  global widget
  set t $widget($sock)
  if {[catch {
    if {![eof $sock]} {
      $t see insert
      puts $sock [$t get "insert linestart " "insert lineend"]
    } else {
      close $sock
      destroy [winfo toplevel $t]
      log "Socket $sock closed"
    }
    update 
  }]} {
    destroy [winfo toplevel $t]
    log "Socket $sock closed"
    return -code break
  }
}

proc sendPaste {sock w} {
  set sel [selection get -displayof $w]
  puts -nonewline $sock $sel
  $w insert end $sel
  return -code break
}

proc receiveConnect {sock remothost port} {
  log "Connect to socket $sock from $remothost by port $port"
  global widget env

  set widget($sock) [makeTerminal .r$sock]
  set t $widget($sock)
  
  bind $t <Return> "send $sock"
  bind $t <Control-d> "close $sock"
  bind $t <<PasteSelection>> "sendPaste $sock %W"

  focus $t
  
  fconfigure $sock -buffering line
  fileevent  $sock readable [list receive $sock]
  puts       $sock "220 welcome to $env(HOST)"
}

proc installServer {port} {
  global server
  set server($port) [socket -server receiveConnect $port]
  log "Server listening on port localhost $port"
}

proc openConnection {host port} {
  global widget log client

  set sock [socket $host $port]
  set client($host:$port) $sock
  set widget($sock) [makeTerminal .0$sock]
  set t $widget($sock)
  
  fconfigure $sock -buffering line
  fileevent  $sock readable [list receive $sock]
  
  bind $t <Return> "send $sock"
  bind $t <Button-2> "sendPaste $sock %W"

  focus $t
}
  
proc command {} {
  global log server client 
  set cmd [$log get "insert linestart " "end - 1 char"]
  $log insert end "\n"
  switch -glob -- [lindex $cmd 0] {
    o* {eval openConnection [lrange $cmd 1 end]}
    s* {eval installServer [lrange $cmd 1 end]}
    l* {
      foreach s [lsort [array names server]] {
	mess "Server on port $server($s)"
      }
      foreach c [lsort [array names client]] {
	mess "Client on host:port $client($c)"
      }
    }
    q* {exit 0}
    default {log "ERROR: unknown command `[lindex $cmd 0]'"}
  }
  return -code break 
}

set log [makeTerminal]
bind $log <Return> command
focus $log

log {
  In this buffer you my enter three different commands:
    open HOST PORT
	to open a connection to another HOST and PORT or
    server PORT
	to install a new server on the PORT of the local machine.
    quit
	to exit the program
  
  Receiving connections will be opened in an extra window per connection.
}

foreach port $argv {
  installServer $port
  set time [clock format [clock seconds]]
}