CkChat

MC, 28 Jan 2003: Here is a ck (curses) based client for the Tcl Chatroom, inspired by TkChat.
DKF, 1 Jan 2008: No longer works, but still a nice idea.
 #!/bin/sh
 # -*- tcl -*- 
 # 
 # CkChat: A minimalistic Ck front end to the Tcl'ers chat
 # Inspired by TkChat
 #
 # Author: Michael A. Cleverly, [email protected]
 #
 # Licensed under the same terms as the Tcl core.
 #            
 # \
 exec cwsh "$0" ${1+"$@"}
 
 package require Tcl  8.3
 package require http 
 
 
 namespace eval ::ckchat {
     # Make sure we can abort Ck if something goes wrong
     bind . <Control-c> exit
     bind . <Control-C> exit
 
     #
     # Edit these configuration settings as needed
     #
 
     variable username EDIT_THIS                          ;# username
     variable password EDIT_THIS                   ;# password
     variable frequency 30                         ;# refresh freq in secs
     variable auto_load_history_p 1                ;# load history on logon?
 
     # End of Configuration Settings
 
 
     if {![info exists connected]} {
         variable connected 0
     }
 
     variable host http://mini.net
     variable fetch_id [after 0 "#"]
     variable online [list]
     variable recent_chatter [list]
     variable history 
     variable self [file join [pwd] [info script]]
     variable RE
 
     set RE(log) {(?x)^(                                       # Timestamp
         (?: Mon | Tue | Wed | Thu | Fri | Sat | Sun )     \s
         (?: Jan | Feb | Mar | Apr | May | Jun | Jul | 
             Aug | Sep | Oct | Nov | Dec             )     \s+
         (?: \s[1-9]   | [12]\d    | 3[01]           )     \s
         \d\d:\d\d:\d\d                                    \s  # HH:MM:SS
         \d\d\d\d)                                         \s  # YYYY
         (\d+\.\d+\.\d+\.\d+)                              \s  # IP Address
         \[MSG\]                                           \s  # [MSG]
         ([^:]+):                                          \s  # Who
         (.+)                                                  # what they said
     }
 
     set RE(online) {<A HREF="[^"]+"[^>]*>([^<]+)</A>}
     set RE(poll) {<BODY[^>]*>\s*(\S.+\S)\s*<A NAME="end">}
     set RE(<BR>) {\s*<[Bb][Rr]>\s*}
 
     array set RE {
         HelpStart  {(?i)^<FONT COLOR=".+?"><B>\[(.+?)\]</B>(.*)$}
         MultiStart {(?i)^<FONT COLOR=".+?"><B>(\S+?)</B>:(.*?)$}
         SectEnd    {(?i)^(.*)</FONT>$}
         Color      {(?i)^<FONT COLOR=".+?">(.*?)</FONT>$}
         Message    {(?i)^<B>(\S+?)</B>:(.+?)$}
         Help       {(?i)^<B>\[(.+?)\]</B>(.*)$}
         Action     {(?i)^<B>\*\s+(\S+)\s+(.+)</B>$}
         Traffic    {(?i)^<B>\s*(\S+)\s+has (entered|left) the chat</B>$}
         System     {(?i)^<B>(.*)</B>$}
     }
 }
 
 
 proc ::ckchat::user_interface {} {
     variable ui 
     variable history
 
     # A text widget + scrollbar to act as the chat log buffer
     frame     .buffer -border {ulcorner hline urcorner vline lrcorner llcorner}
     scrollbar .buffer.scroll -command {.buffer.text yview}
     text      .buffer.text   -state disabled   \
                              -background black \
                              -width  78        \
                              -height 21        \
                              -takefocus 0      \
                              -wrap word        \
                              -yscrollcommand {.buffer.scroll set}
 
     pack .buffer.scroll -side right -fill y
     pack .buffer.text   -side left  -fill both -expand 1
 
     set ui(orig_scroll_bg)  [.buffer.scroll cget -background]
     set ui(orig_scroll_abg) [.buffer.scroll cget -activebackground]
     set ui(alt_scroll_bg)  white
     set ui(alt_scroll_abg) white
 
     array set tags {
         system {-foreground red -attributes bold}
         date   {-foreground yellow -attributes bold -lmargin2 4}
         who    {-foreground magenta -attributes bold}
         bold   {-foreground white -lmargin2 4 -attributes bold}
         chat   {-foreground white -lmargin2 4}
         cont   {-foreground white -lmargin1 4 -lmargin2 4}
         tcl    {-foreground green -attributes bold}
     }
     
     foreach tag [array names tags] {
         eval .buffer.text tag configure $tag $tags($tag)
     }    
 
     # Input field for commands & messages  
     array set history [list before {} after {}]
     set ui(entry) ""
 
     frame .input -border {}
     entry .input.entry -textvariable ::ckchat::ui(entry) -attributes bold
     pack  .input.entry -expand 1 -fill x
 
     # Bindings for control keys on the entry widget
     bind .input.entry <Linefeed> ::ckchat::user_input
     bind .input.entry <Return>   ::ckchat::user_input
 
     bind .input.entry <Up>    ::ckchat::history_up
     bind .input.entry <Down>  ::ckchat::history_down
 
     bind .input.entry <Prior> ::ckchat::buffer_page_up
     bind .input.entry <Next>  ::ckchat::buffer_page_down
 
     bind .input.entry <Control-t> ::ckchat::buffer_totally_up
     bind .input.entry <Control-T> ::ckchat::buffer_totally_up
     bind .input.entry <Control-b> ::ckchat::buffer_totally_down
     bind .input.entry <Control-B> ::ckchat::buffer_totally_down
 
 
     # Arrange the layout of the screen & give the focus to the entry widget
     grid configure .buffer -column 0 -row 0 -sticky nsew
     grid configure .input  -column 0 -row 1 -sticky ew
     focus .input.entry
     after idle [list ::ckchat::log "CkChat 1.0:  /help for help" system]
 }
 
 
 proc ::ckchat::history_up {} {
     variable ui
     variable history
     set entry $ui(entry)
 
     if {[llength $history(before)] == 0} {
         if {[string equal [string trim $entry] ""]} {
             bell
         } else {
             set ui(entry) ""
             set history(after) [linsert $history(after) 0 $entry]
         }
     } else {
         if {![string equal $entry [lindex $history(after) 0]] &&
             ![string equal [string trim $entry] ""]} {
             set history(after) [linsert $history(after) 0 $entry]
         }
 
         set ui(entry) [lindex $history(before) end]
         set history(before) [lrange $history(before) 0 end-1]
     }
 }
 
 
 proc ::ckchat::history_down {} {
     variable ui
     variable history
     set entry $ui(entry)
 
     if {[llength $history(after)] == 0} {
         if {[string equal [string trim $entry] ""]} {
             bell
         } else {
             set ui(entry) ""
             lappend history(before) $entry
         }
     } else {
         if {![string equal $entry [lindex $history(before) end]] &&
             ![string equal [string trim $entry] ""]} {
             lappend history(before) $entry
         } 
         
         set ui(entry) [lindex $history(after) 0]
         set history(after) [lrange $history(after) 1 end]
     }
 }
 
 
 proc ::ckchat::buffer_page_up {} {
     .buffer.text yview scroll -1 pages
 }
 
 
 
 proc ::ckchat::buffer_page_down {} {
     .buffer.text yview scroll 1 pages
     if {[llength [.buffer.text bbox "end - 1 char"]]} {
         variable ui
         .buffer.scroll configure -background $ui(orig_scroll_bg)
         .buffer.scroll configure -activebackground $ui(orig_scroll_abg)
     }
 }
 
 
 proc ::ckchat::buffer_totally_up {} {
     .buffer.text yview moveto 0
 }
 
 
 proc ::ckchat::buffer_totally_down {} {
     .buffer.text yview moveto 1
     if {[llength [.buffer.text bbox "end - 1 char"]]} {
         variable ui
         .buffer.scroll configure -background $ui(orig_scroll_bg)
         .buffer.scroll configure -activebackground $ui(orig_scroll_abg)
     }
 }
 
 
 proc ::ckchat::user_input {} {
     variable ui 
     variable history
 
     set entry [string trim $ui(entry)]
     set ui(entry) ""
 
     if {[string equal $entry ""]} {
         return
     }
      
     set command /say
     set input $entry
     regexp {^(?:(/\w+) *)(.*)$} $entry => command input
 
     if {![string equal [lindex $history(before) end] $entry] &&
         ![string equal [string trim $entry] ""]} {
         lappend history(before) $entry
     }
      
     if {[info commands ::ckchat::$command] != ""} {
         ::ckchat::$command $input
     } else {
         bell
         log "\nNo such command: $command (::ckchat::$command)" system
     }
 }
 
 
 proc ::ckchat::log args {
     variable ui
 
     set auto_scroll_p [llength [.buffer.text bbox "end - 1 char"]]
     .buffer.text configure -state normal -takefocus 1
     eval .buffer.text insert end $args
     .buffer.text configure -state disabled -takefocus 0
 
     if {$auto_scroll_p} {
         .buffer.text see "end - 1 char"
         .buffer.scroll configure -background $ui(orig_scroll_bg)
         .buffer.scroll configure -activebackground $ui(orig_scroll_abg)
     } else {
         .buffer.scroll configure -background $ui(alt_scroll_bg)
         .buffer.scroll configure -activebackground $ui(alt_scroll_abg)
     }
 }
 
 
 proc ::ckchat::format_date {date format} {
     clock format [clock scan $date] -format $format
 }
 
 
 proc ::ckchat::geturl url {
     if {[catch {
         set token [::http::geturl $url -command "#"]
         ::http::wait $token
         set html [::http::data $token]
         ::http::cleanup $token
     } problem]} {
         log "\nError fetching $url" system
         log "\n$problem" system
         return
     }
     return $html
 }
 
 
 proc ::ckchat::posturl {url query} {
     if {[catch {
         set query [string map [list %5f _] $query]
         set token [::http::geturl $url -query $query -command "#"]
         ::http::wait $token
         set html [::http::data $token]
         ::http::cleanup $token
     } problem]} {
         log "\nError posting $url" system
         log "\n$problem" system
         return
     }
     return $html
 }
 
 
 proc ::ckchat::poll_chat {} {
     variable host
     variable username
     variable password
     variable connected
     variable fetch_id
     variable frequency
     variable online
     variable RE
     variable recent_chatter 
 
     after cancel $fetch_id
     if {!$connected} {
         bell
         log "\nCannot poll; not currently connected." system
         return
     }
 
     set query [::http::formatQuery \
         action          stillalive \
         name            $username  \
         password        $password  \
         color           000000      \
         updatefrequency 600        \
         new_msg_on_top  0          \
         ls              ""]
 
     set html [posturl $host/cgi-bin/chat.cgi $query]
     foreach {full name} [regexp -inline -all $RE(online) $html] {
         lappend currently_online $name
     }
 
     if {[info exists currently_online]} {
         set online $currently_online
     }
     
     set query [::http::formatQuery \
         action          chat       \
         name            $username  \
         password        $password  \
         color           000000      \
         updatefrequency 600        \
         new_msg_on_top  0          \
         ls              ""]
 
     set html [posturl $host/cgi-bin/chat.cgi $query]
 
     if {[regexp $RE(poll) $html => conversation]} {
         set lines [list]
         regsub -all $RE(<BR>) $conversation \x00 conversation
 
         foreach item [split $conversation \x00] {
             if {[string length $item]} {
                 lappend lines $item
             }
         }
 
         set found 0
         set mark  0
         set end [lindex $recent_chatter end]
         set len [llength $recent_chatter]
 
         while {1} {
             set idx [lsearch -exact [lrange $lines $mark end] $end]
             if {$idx == -1} then break
 
             set num  [expr {$mark + $idx}]
             set back [expr {$len - $num - 1}]
             set l1   [join [lrange $lines 0 $num] +]
             set l2   [join [lrange $recent_chatter $back end] +]
             set mark [incr num]
             
             if {[string equal $l1 $l2]} {
                 set found $mark
             }
         }
 
         set lines [lrange $lines $found end]
 
         foreach line $lines {
             lappend recent_chatter $line
         }
 
         if {[llength $recent_chatter] > 500} {
             set history [lrange $recent_chatter end-499 end]
         }
 
         set in_help_p 0
         set in_mesg_p 0
 
         foreach line $lines {
             regexp -nocase -- $RE(Color) $line => line
              
             if {$in_help_p} {
                 if {[regexp $RE(SectEnd) $line => text]} {
                     lappend help_lines $text
                     set in_help_p 0
                     add-help $help_name [join $help_lines "\n    "]
                 } else {
                     lappend help_lines [string trimright $line]
                 }
             } elseif {$in_mesg_p} {
                 if {[regexp $RE(SectEnd) $line => text]} {
                     lappend mesg_lines [string trimright $text]
                     set in_mesg_p 0
                     add-message $nick [join $mesg_lines "<BR>"]
                 } else {
                     lappend mesg_lines [string trimright $line]
                 }
             } else {
                 if {[regexp $RE(HelpStart) $line => name text]} {
                     set in_help_p 1
                     set help_name $name
                     set help_lines [list $text]
                 } elseif {[regexp $RE(MultiStart) $line => name text]} {
                     set in_mesg_p 1
                     set nick $name
                     set mesg_lines [list [string trimright $text]]
                 } elseif {[regexp $RE(Message) $line => nick text]} {
                     add-message $nick [string trim $text]
                 } elseif {[regexp $RE(Help) $line => name text]} {
                     add-help $name [string trim $text]
                 } elseif {[regexp $RE(Action) $line => nick text]} {
                     add-action $nick $text
                 } elseif {[regexp $RE(System) $line => text]} {
                     if {[regexp $RE(Traffic) $line => who action]} {
                         add-traffic $who $action
                     } else {
                         add-system $text
                     }
                 } else {
                     # Didn't recognize $line, assume help
                     add-help Unknown? [string trim $line]
                 }
             } 
         }
     }
 
     set fetch_id [after [expr {$frequency * 1000}] ::ckchat::poll_chat]
 }
 
 
 proc ::ckchat::/poll input poll_chat
 
 
 proc ::ckchat::/load input {
     variable RE
     variable host
 
     log "\n<history>" system
 
     array set urls {}
     set html [geturl $host/tchat/logs/]
 
     foreach date [regexp -inline -all {\d{4}-\d{1,2}-\d{1,2}\.txt} $html] {
         foreach {yyyy mm dd} [split $date -.] break
         set mm [format %02d $mm]
         set dd [format %02d $dd]
         set urls($yyyy-$mm-$dd) $host/tchat/logs/$date
     }
 
     set counter 0
     foreach date [lsort [array names urls]] {
         set pretty_date [format_date $date "%A, %B %e %Y"]
         log \n system
         log "Chat history from $pretty_date" system
 
         set history [string map [list \n< <] [geturl $urls($date)]]
         
         foreach line [split $history \n] {
             if {[regexp $RE(log) $line => time ip who message]} {
                 add-message $who $message $time
             }
 
             if {([incr counter] % 25) == 0} then update
         }
     }
 
     log \n</history> system
 }
 
 
 proc ::ckchat::decode-entities {text} {
     return [string map -nocase [list "&lt;"  <  \
                                      "&gt;"  >  \
                                      "&amp;" &  \
                                      "<BR>"  \n \
                                      "<P>"   \n\n] $text]
 }
 
 
 proc ::ckchat::strip-html {html} {
     regsub -all -- {<[^>]*>} $html "" html
     return $html
 }
 
 
 proc ::ckchat::add-message {who message {time now}} {
     set message [decode-entities $message]
     set message [strip-html $message]
     set message [split $message \n]
 
     log \n chat
     log [format_date $time "%a %H:%M: "] date
     log "$who: " who
     log [lindex $message 0] chat
 
     foreach  continued_line [lrange $message 1 end] {
         log $continued_line cont
     }
 }
 
 
 proc ::ckchat::add-system {text} {
     log \n chat
     log [format_date now "%a %H:%M: "] date
     log $text system
 }
 
 
 proc ::ckchat::add-traffic {who action} {
     log \n chat
     log [format_date now "%a %H:%M: "] date
     log $action: bold
     log " $who" who
 }
 
 
 proc ::ckchat::add-help {type message} {
     variable online
 
     set message [decode-entities $message]
     set message [strip-html $message]
 
     if {[lsearch -exact $online $type] != -1} {
         log \n chat
         log [format_date now "%a %H:%M: "] date
         log "* $type " who
         log "whispers: " bold
         log $message chat
         return
     }
 
     if {[string match "->*" $type]} {
         log \n chat
         log [format_date now "%a %H:%M: "] date
         log "* you " who
         log "whispered to " bold
         log "$type: " who
         log $message chat
         return
     }
 
     set message [split $message \n]
 
     log \n chat
     log [format_date now "%a %H:%M: "] date
     log "[string trim "$type help:"] " system
     log [lindex $message 0] chat
 
     foreach  continued_line [lrange $message 1 end] {
         log $continued_line cont
     }
 }
 
 proc ::ckchat::add-action {nick text} {
     log \n chat
     log [format_date now "%a %H:%M: "] date
     log "* $nick " who
     log $text chat
 }
 
 
 proc ::ckchat::/say {input {destination ""}} {
     if {[string length $input] == 0} then return
 
     variable host
     variable username
     variable password
 
     set query [::http::formatQuery   \
         action          postmsg      \
         name            $username    \
         password        $password    \
         color           000000        \
         updatefrequency 600          \
         new_msg_on_top  0            \
         ls              ""           \
         msg_to          $destination \
         msg             $input]
 
     set html [posturl $host/cgi-bin/chat.cgi $query]
 
     switch -regexp -- $html {
         "Nick doesn't exist" {
             log "\nSend failed; username doesn't exist" system
         }
 
         "Wrong Password" {
             log "\nSend failed; invalid password given" system
         }
 
         ACTION {}
 
         default {
             log "\nSend appears to have failed(?)" system
         }
     }
 }
 
 
 proc ::ckchat::/me input {
     if {[string length $input] == 0} then return
     /say "/me $input"
 }
 
 
 proc ::ckchat::/msg input {
     if {[regexp {^\s*(\w+)\s+(.+)$} $input => destination message]} {
         /say $message $destination
     }
 }
 
 
 proc ::ckchat::/quit input exit
 proc ::ckchat::/exit input exit
 
 
 proc ::ckchat::/eval input {
     if {[info complete $input]} {
         log "\n% $input" tcl
         catch { eval $input } result
         log \n$result tcl
     } else {
         bell
         log "\nError: command not complete: $input" system
     }
 }
 
 
 proc ::ckchat::/logon input {
     variable host
     variable username
     variable password
     variable fetch_id
     variable connected
     variable auto_load_history_p
 
     regexp {^\s*(\S+)(?:\s+(\S+))?} $input => user pass
 
     if {![info exists user]} {
         set user $username
     }
 
     if {![info exists pass] || [string length $pass] == 0} {
         set pass $password
     }
 
     if {[string length $user] == 0} {
         log "\nCannot connect without specifying a username" system
         return
     }
 
     if {[string length $pass] == 0} {
         log "\nCannot connect without specifying a password for $user" system
         return
     }
 
     set query [::http::formatQuery \
         action   login             \
         name     $user             \
         password $pass]
 
     log "\nAttempting to login to $host/cgi-bin/chat2.cgi" system
     set html [posturl $host/cgi-bin/chat2.cgi $query]
 
     switch -regexp -- $html {
         "Nick doesn't exist" {
             log "\nLogin failed; username doesn't exist" system
         }
 
         "Wrong Password" {
             log "\nLogin failed; invalid password given" system
         }
 
         stillalive {
             set username $user
             set password $pass
             log "\nLogin succeeded!" system
             set connected 1
 
             if {[string is true -strict $auto_load_history_p]} {
                 /load history-automatically
             }
             
             set fetch_id [after 0 ::ckchat::poll_chat]
         }
 
         default {
             log "\nLogin appears to have failed(?)" system
         }
     }
 }
 
 
 proc ::ckchat::/logoff input {
     variable host
     variable connected
     variable fetch_id
 
     after cancel $fetch_id
     set query [::http::formatQuery action gotourl url chat.cgi]
     posturl $host/cgi-bin/chat2.cgi $query
     
     if {$connected} {
         set connected 0
         log "\nLogged off" system
     } else {
         log "\nYou aren't logged in" system
     }
 }
 
 
 proc ::ckchat::/who input {
     variable online
     variable connected
 
     if {$connected} {
         log "\n/who is currently online: " system
         log [join $online ", "] who
     } else {
         if {[llength $online] == 0} {
             log "\n/who is currently online? login first to find out..." system
         } else {
             log "\n/who was online: " system
             log [join $online ", "] who
         }
     }
 }
 
 
 proc ::ckchat::/reload input {
     variable self
 
     log "\nReloading $self ... " system
     catch { source $self }
     log "reloaded!" system
 }
 
 
 proc ::ckchat::/help input {
     log \n chat
     log "CkChat -- A minimalistic front end to the Tcl'ers Chat\n" bold
     log "Inspired by TkChat.\n\n" bold
     log "Commands:\n" chat
     log "/logon ?username? ?password?" cont
     log " (defaults in script used if not overriden)\n" bold
     log "/logoff\n" cont
     log "/who\n" cont
     log "/me <what you want to emote>\n" cont
     log "/say <what you want to say>" cont 
     log " (implicit if the input doesn't begin with /)\n" bold
     log "/poll" cont
     log " (poll for new messages immediately)\n" bold
     log "/tcl script\n" cont
     log "/eval script\n" cont
     log "/reload\n" cont
 }
 
 
 # Convenience aliases
 interp alias {} ::ckchat::/tcl    {} ::ckchat::/eval
 interp alias {} ::ckchat::/login  {} ::ckchat::/logon
 interp alias {} ::ckchat::/logout {} ::ckchat::/logoff
 
 
 if {[info commands .buffer] == ""} {
     ::ckchat::user_interface
 }
Category Application
Category Text Screen