You might want to have a look at http://www.dedasys.com/freesoftware/
where you can find tclchat, which has both web and tk interfaces. #!/bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" ${1+"$@"}
set port 1234
proc handle_connection {client_socket host port} {
global client_sockets counter name2socket socket2name
set client_name "Unnamed$counter"
incr counter
announce "* $client_name has connected."
lappend client_sockets $client_socket
set name2socket($client_name) $client_socket
set socket2name($client_socket) $client_name
fconfigure $client_socket -buffering line
fileevent $client_socket readable [list receive_line_from $client_socket]
puts $client_socket "You are logged in as \"$client_name\". Type \"help\" to see a rundown of commands."
}
proc receive_line_from {client_socket} {
global client_sockets name2socket socket2name
set client_name $socket2name($client_socket)
if {[catch {gets $client_socket line} send_error]} {
clean_up_client $client_socket
announce "* $client_name has disconnected \[Error: $error\]."
return
} elseif {[eof $client_socket]} {
clean_up_client $client_socket
announce "* $client_name has disconnected \[Connection closed by client\]."
return
}
if {$line == ""} {
puts $client_socket "You must enter some command."
return
}
set first_character [string index $line 0]
set rest [string range $line 1 end]
if {$first_character == "\""} {
set command_name "say"
set command_data $rest
} elseif {$first_character == ":"} {
set command_name "me"
set command_data $rest
} elseif {![regexp {^(.+?) (.*)} $line dummy command_name command_data]} {
# If the above line fails to find a command with supplied data, then set the
# command name to the whole string and the data to an empty string
set command_name $line
set command_data ""
}
switch -- $command_name {
say {
announce "$client_name says, \"$command_data\""
}
me {
announce "$client_name $command_data"
}
who {
puts $client_socket "The following people are online:"
puts $client_socket "------------"
foreach wsocket $client_sockets {
puts $client_socket $socket2name($wsocket)
}
puts $client_socket "------------"
}
name {
set new_name $command_data
if {$new_name == $client_name} {
puts $client_socket "You already are using that name."
} elseif {[string is word $new_name] && [string length $new_name] <= 20} {
foreach wsocket $client_sockets {
if {$socket2name($wsocket) == $new_name} {
puts $client_socket "That name is already in use."
return
}
}
set socket2name($client_socket) $new_name
unset name2socket($client_name)
set name2socket($new_name) $client_socket
announce "* $client_name is now known as $new_name."
} else {
puts $client_socket "You must pick a name which is at most 20 characters long and which consists of only alphanumeric characters and underscores."
}
}
help {
puts $client_socket "Command rundown:"
puts $client_socket " say Hello (or) \"Hello"
puts $client_socket " me waves (or) :waves"
puts $client_socket " who"
puts $client_socket " name New_Name"
puts $client_socket " help"
}
default {
puts $client_socket "Invalid command."
}
}
}
proc announce {message} {
global client_sockets
foreach client_socket $client_sockets {
puts $client_socket $message
}
}
proc clean_up_client {client_socket} {
global name2socket socket2name client_sockets
close $client_socket
set pos [lsearch -exact $client_sockets $client_socket]
set client_sockets [lreplace $client_sockets $pos $pos]
unset name2socket($socket2name($client_socket)) socket2name($client_socket)
}
set client_sockets [list]
array set name2socket [list]
array set socket2name [list]
set counter 1
if {[catch {socket -server handle_connection $port} listen_error]} {
puts "Failed to listen for connections on $port: $listen_error"
} else {
puts "Server started on port $port!"
vwait forever
}