Updated 2011-07-13 13:27:21 by RLE

I (FW) created a little (~4k) chatserver in Tcl, which allows people to connect via a telnet client, or some other raw text-based program, and chat with others. People are assigned a unique name (the word "Unnamed" followed by an integer) and may subsequently rename themselves to their liking. Features included are a couple of different methods of communicating - the "say" command, which just sends a standard message, and the "me" command, which is roughly equivilant to the /me command in IRC (the one character shortcuts '"' and ':' are available for these, respectively); the "who" command, which lists the people online; the "name" command, which lets you reset your name; and the "help" command, which simply spits out a summary of the aforementioned commands.

I fancy this code so lucid it's almost self-documenting (thank the language for that, not me) and it serves to show a lot of the elegance of Tcl.

Update: Fixed a small bug with the : shortcut to the "me" command.

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
 }