picoIRC 0.3

SS The following is a new version of picoIRC 0.2, a tiny IRC client that adds support for private query, nick colorization using an hash function, the /join, /nick, /names, /msg, /quit commands, auto resolution of nick collisions, colorized user list on join. Not as short as the first versions we wrote, but considering the feature set this script continues to show that Tcl is great to get a lot with little work.
 package require Tk
 set ::registered 0
 set ::joined 0
 set ::server irc.freenode.org
 set ::chan   #tcl
 set ::me     $tcl_platform(user)
 set ::meseq  0 ;# sequencial number to add to the NICK if the previous was busy
 set ::names {}
 text .t -height 30 -wrap word -font {Arial 9} -background white
 .t tag config bold   -font [linsert [.t cget -font] end bold]
 .t tag config italic -font [linsert [.t cget -font] end italic]
 set ::colors {red blue darkgreen black darkcyan darkmagenta}
 foreach color $::colors {
     .t tag config $color -foreground $color
 }
 entry .cmd -background white
 pack .cmd -side bottom -fill x
 pack .t -fill both -expand 1
 bind .cmd <Return> post
 focus .cmd
 
 proc nickcolor nick {
     binary scan $nick c* v
     set hash 4817
     set op +
     foreach x $v {
         set hash [expr "$hash $op $x"]
         set op [if {$op eq {+}} {concat *} {concat +}]
     }
     set hash [expr {$hash%[llength $::colors]}]
     lindex $::colors $hash
 }
 
 proc shownames {} {
     .t insert end "\nNames:\n" bold
     set i 0
     foreach n $::names {
         if {$i == 0} {
             .t insert end [string repeat " " 8]
         }
         .t insert end "$n " [nickcolor $n]
         if {[incr i] eq 5} {
             .t insert end "\n"
             set i 0
         }
     }
     if {$i} {.t insert end "\n\n"}
     .t yview end
 }
 
 proc recv {} {
     gets $::fd line
     puts $line
     # handle PING messages from server (lpz 2012 06 18)
     if {[lindex [split $line] 0] eq "PING"} {
        send "PONG [info hostname] [lindex [split $line] 1]"
        return
     }
     if {[regexp {:([^!]*)![^ ].* +PRIVMSG ([^ :]+) +:(.*)} $line -> \
         nick target msg]} {
         set tag ""
         if {$nick eq "ijchain"} {regexp {<([^>]+)>(.+)} $msg -> nick msg}
         if [regexp {\001ACTION(.+)\001} $msg -> msg] {
             set msg "$nick $msg"
             set nick "*"
             set tag {bold darkgreen}
             set nicktag bold
         } else {
             set nicktag [nickcolor $nick]
         }
         if {[string index $target 0] ne {#}} {
             set nick "=== $nick ==="
             lappend nicktag bold
         }
        .t insert end $nick\t $nicktag $msg\n $tag
     } elseif {[regexp {^:([^ ]+) +([^ ]+) +([^ ]+) +(.*)} $line -> \
                server code target rest]} \
     {
         switch -- $code {
             001 {
                 set ::registered 1
             }
             433 {
                 set seqlen [string length [incr ::meseq]]
                 set ::me [string range $::me 0 [expr 8-$seqlen]]$::meseq
                 send "NICK $::me"
             }
             353 {
                 if {[regexp {[^:]*:(.*)} $rest -> nameslist]} {
                     foreach name $nameslist {
                         lappend ::names $name
                     }
                 }
             }
             366 {
                 shownames
                 set ::names {}
             }
         }
         .t insert end $line\n italic
     } else {
         .t insert end $line\n italic
     }
     .t yview end
 }
 
 proc usererr msg {
     .t insert end "--- $msg\n" {bold red}
     .t yview end
 }
 
 proc post {} {
     set msg [.cmd get]
     .cmd delete 0 end
     if [regexp {^/([^ ]+) *(.*)} $msg -> cmd msg] {
         switch -- $cmd {
             me {set msg "\001ACTION $msg\001"}
             nick {send "NICK $msg"; set ::me $msg}
             quit {send "QUIT $msg"; exit}
             names {send "NAMES $::chan"}
             quote {send $msg}
             join {
                 send "PART $::chan"
                 send "JOIN $msg"
                 set ::chan $msg
             }
             msg {
                 if {[regexp {([^ ]+) +(.*)} $msg -> target querymsg]} {
                     send "PRIVMSG $target :$msg"
                     set tags [list [nickcolor $target] bold]
                     set target ">>> $target <<<"
                     .t insert end $target\t $tags $querymsg\n {black bold}
                     .t yview end
                 }
             }
             default {usererr "unknown command /$cmd"}
         }
         if {$cmd ne {me} || $cmd eq {msg}} return
     }
     if [regexp {^/me (.+)} $msg -> action] {set msg "\001ACTION $action\001"}
     foreach line [split $msg \n] {send "PRIVMSG $::chan :$line"}
     set tag ""
     if [regexp {\001ACTION(.+)\001} $msg -> msg] {set tag italic}
     .t insert end $::me\t {bold blue} $msg\n [list blue $tag]
     .t yview end
 }
 
 proc send str {
     puts $::fd $str
     flush $::fd
 }
 
 proc cron {} {
     if {!$::joined && $::registered} {
         send "JOIN $::chan"
         set ::joined 1
     }
     after 2000 cron
 }
 
 set ::fd [socket $::server 6667]
 send "NICK $::me"
 send "USER $::me 0 * :PicoIRC user"
 send "JOIN $::chan"
 
 fileevent $::fd readable recv
 bind . <Escape> {exec wish $argv0 &; exit}
 cron
Category Application
Category Internet