Version 20 of Tclers Chat Tk GUI

Updated 2006-01-19 02:44:16

Purpose: discuss a Tk based interface to the Tcler's Wiki chat room at [L1 ] .


The TkChat client has been added to the sourceforge Project tcllib in SF module tclapps. Get the latest version there. http://sf.net/projects/tcllib/ - it is now a part of tclapps module in tcllib's cvs repository.


The latest version can be aquired by this link http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/*checkout*/tcllib/tclapps/apps/tkchat/tkchat.tcl?rev=HEAD

GPS: Oct 10, 2003 - I updated the link above to use *checkout* rather than ~checkout~. It seems that SourceForge changed something...


Note that tkchat requires tcllib 1.0 , Tcl/Tk 8.3 .


If you would like to use tkchat in conjuntion with your own chat server you will need an older version of ralfs chat. The newer versions are not backwards compatible with tkchat.

A vintage of ralfs chat compatible with the tkchat in cvs can be found at http://mini.net/pub/ralf.tar.gz courtesy of JCW

Soon i'll make a patch to tkchat that will allow you to connect to an arbitrary chat server right now you have to hack in a few lines of change in order to make it work with a chat server other than the one at mini.net -mikeH


There is also a self-contained starkit at http://www.digital-smarties.com/pub/tkchat - understand that this is a binary file to download.


The tkchat starkit would be more useful if it were self-contained . Right now, it doesn't include tcllib - and tclkit (at least the last one created for MacOS classic) doesn't include tcllib.

You can get tcllib in a starkit as part of Kitten [L2 ] -- the idea of TclKit is not to incorporate more and more extension capabilities (and require rebuilding all the time), but to be an infrastructure which supports starkits *with* such extensions - JCW


I wonder how we figure out WHAT version of tkchat it is - as far as I know, there isn't any versioning in the script yet.

- The tkchat code has the rcs ID embedded into a variable now. - PT 14Nov01


STOP! Don't get the code included on this page! Instead, get it from the sourceforge site.


 #!/bin/wish
 #
 # Tk front end to the Tcl'ers chat
 #
 ###########################################################
 #
 # author: Bruce B Hartweg [email protected]
 #
 # This program is free to use, modify, extend
 # at will, the autor provides no warantees, guarantees
 # or any responsibility for the use, re-use, abuse
 # that may or may not happen. If you somehow sell
 # this and make a ton of money - good for you, how
 # about sending me some?
 ############################################################
 #
 # Suggestions can be sent to the author - fixes even better!
 # If you update this file on the Wiki PLEASE add to the change
 # log so others can see what has been done so fizxes/changes
 # aren't lost or overwritten
 #
 ############################################################
 # Change Log:
 #
 # Date       Name             Comments
 # ---------  ---------------  ---------------------------------
 # 26Sep2001  B. Hartweg       Initial release to wiki
 # 26Sep2001  J. Hobbs         several enhancements
 # 27Sep2001  B. Hartweg       Add font selections
 # 27Sep2001  B. Hartweg       Add URL handling & minor fixes
 # 27Sep2001  P. Thoyts        Support for Proxy Authentication
 # 27Sep2001  D. Porter        Bug fix in findExecutable
 #
 ############################################################
 package require http
 package require textutil
 package require htmlparse 0.2
 package require base64
 package require Tk 8.3

 namespace eval ::wikichat {
     # Everything will eventually be namespaced
 }

 set ::DEBUG 1
 proc vputs {args} {
     if {$::DEBUG} {
         set name [lindex [uplevel 1 info level 0] 0]
         if {[llength $args]} {
             puts "$name: $args"
         } else {
             puts "CALLED $name"
         }
     }
 }

 proc errLog {args} {
     puts stderr [join $args]
     update idletasks
 }

 # If Proxy Authentication was specified then each HTTP request
 # must have an authentication header. This procedure supports 
 # proxys accepting Basic authentication by building the header
 # required from the users login and password.
 #  - PT
 proc buildProxyHeaders {} {
     global Options
     set auth {}
     if { $Options(UseProxy) \
              && [info exists Options(ProxyUsername)] \
              && $Options(ProxyUsername) != {} } {
        set auth [list "Proxy-Authorization" \
                      [concat "Basic" \
                           [base64::encode \
                                $Options(ProxyUsername):$Options(ProxyPassword)]]]
     }
     return $auth
 }

 proc msgSend {str {user ""}} {
     global Options
     set qry [::http::formatQuery \
                    action postmsg \
                    name $Options(Username) \
                    password $Options(Password) \
                    color $Options(MyColor) \
                    updatefrequency 600 \
                    new_msg_on_top 0 \
                    ls  "" \
                    msg_to $user \
                    msg  $str \
                   ]
     ::http::geturl $Options(URL) \
           -query [string map {%5f _} $qry] \
           -headers [buildProxyHeaders] \
           -command msgDone
 }

 proc msgDone {tok} {
     errLog "Post: status was [::http::status $tok]"
     switch [::http::status $tok] {
         ok { if {[catch {fetchPage} err]} { errLog $err } }
         reset { errLog "User reset post operation" }
         timeout { tk_messageBox -message "Message Post timed out" }
         error {
             tk_messageBox -message \
                   "Message Post Errored: [::http::error $tok]"
         }
     }
     ::http::cleanup $tok
 }

 proc logonChat {} {
     global Options
     set qry [::http::formatQuery \
                    action login \
                    name $Options(Username) \
                    password $Options(Password) \
                   ]
     ::http::geturl $Options(URL2) \
           -query $qry \
          -headers [buildProxyHeaders] \
           -command logonDone
 }

 proc logonDone {tok} {
     errLog "Logon: status was [::http::status $tok]"
     switch [::http::status $tok] {
         ok { if {[catch {pause off} err]} { errLog $err } }
         reset { errLog "User reset logon operation" }
         timeout { tk_messageBox -message "Logon timed out" }
         error { tk_messageBox -message "Logon Error: [::http::error $tok]" }
     }
     ::http::cleanup $tok
 }
 proc logoffChat {} {
     global Options
     set qry [::http::formatQuery \
                    action gotourl \
                    url  chat.cgi \
                   ]
     ::http::geturl $Options(URL2) \
           -query $qry \
           -headers [buildProxyHeaders] \
           -command logoffDone
     logonScreen
 }

 proc logoffDone {tok} {
     errLog "Logoff: status was [::http::status $tok]"
     # don't really care if this works or not
     ::http::cleanup $tok
 }

 proc pause {pause {notify 1}} {
     global Options
     set ::wikichat::pause [string is true -strict $pause]
     if {$pause} {
         after cancel $Options(FetchTimerID)
         after cancel $Options(OnlineTimerID)
         catch {::http::reset $Options(FetchToken)}
         catch {::http::reset $Options(OnlineToken)}
         if {$notify} {
             if {![winfo exists .pause]} {
                 toplevel .pause -class dialog
                 wm withdraw .pause
                 wm transient .pause .
                 pack [label .pause.m -text \
                             "The session is paused,\nno updates will occur."]
                 button .pause.r -text "Resume" \
                       -command { pause off ; wm withdraw .pause }
                 pack .pause.r -padx 5 -pady 10
                 bind .pause <Destroy> [list pause off]
             }
             catch {::tk::PlaceWindow .pause widget .}
             wm deiconify .pause
             raise .pause
         }
     } else {
         fetchPage
         onlinePage
     }
 }

 proc fetchPage {} {
     global Options

     if {[info exists Options(FetchToken)]} {
         # already fetching page, don't start again
         return
     }

     after cancel $Options(FetchTimerID)
     set Options(FetchTimerID) -1
     set qry [::http::formatQuery \
                    action chat \
                    name $Options(Username) \
                    password $Options(Password) \
                    color $Options(MyColor) \
                    updatefrequency 600 \
                    new_msg_on_top 0 \
                    ls  "" \
                   ]
     set Options(FetchToken) [::http::geturl $Options(URL) \
                                    -query $qry \
                                    -headers [buildProxyHeaders] \
                                    -command fetchDone]
 }

 proc fetchDone {tok} {
     global Options
     if {[string equal $tok $Options(FetchToken)]} {
         unset Options(FetchToken)
     } else {
         errLog "Fetch Command finished with token $tok" \
               "expected $Options(FetchToken)"
         unset Options(FetchToken)
     }
     if {!$::wikichat::pause} {
         set Options(FetchTimerID) [after $Options(RefreshMS) fetchPage]
     }
     errLog "Fetch: status was [::http::status $tok]"
     switch [::http::status $tok] {
         ok - OK - Ok {
             if {[catch {parseData [::http::data $tok]} err]} { errLog $err }
         }
         reset - Reset - RESET {
             errLog "User reset post operation"
         }
         timeout - Timeout - TIMEOUT {
             tk_messageBox -message "Message Post timed out"
         }
         error - Error - ERROR {
             tk_messageBox -message "Message Post Errored: [::http::error $tok]"
         }
     }
     ::http::cleanup $tok
 }

 proc onlinePage {} {
     global Options
     if {[info exists Options(OnlineToken)]} {
         # already fetching page, don't start again
         return
     }

     after cancel $Options(OnlineTimerID)
     set Option(OnlineTimerID) -1
     set qry [::http::formatQuery \
                    action stillalive \
                    name $Options(Username) \
                    password $Options(Password) \
                    color $Options(MyColor) \
                    updatefrequency 600 \
                    new_msg_on_top 0 \
                    ls  "" \
                   ]
     set Options(OnlineToken) [::http::geturl $Options(URL) \
                                     -query $qry \
                                    -headers [buildProxyHeaders] \
                                     -command onlineDone]
 }

 proc onlineDone {tok} {
     global Options
     if {[string equal $tok $Options(OnlineToken)]} {
         unset Options(OnlineToken)
     } else {
         errLog "Online Command finished with token $tok" \
               "expected $Options(OnlineToken)"
         unset Options(OnlineToken)
     }
     if {!$::wikichat::pause} {
         set Options(OnlineTimerID) [after $Options(RefreshMS) onlinePage]
     }
     errLog "Online: status was [::http::status $tok]"
     switch [::http::status $tok] {
         ok {
             if {[catch {updateNames [::http::data $tok]} err]} { errLog $err }
         }
         reset {
             errLog "User reset post operation"
         }
         timeout {
             tk_messageBox -message "Message Post timed out"
         }
         error {
             tk_messageBox -message "Message Post Errored: [::http::error $tok]"
         }
     }
     ::http::cleanup $tok
 }

 proc updateNames {rawHTML} {
     set i 0
     .names config -state normal
     .names delete 1.0 end
     set exp {<A HREF="(.+?)".*?>(.+?)</A>}
     foreach {full url name} [regexp -nocase -all -inline -- $exp $rawHTML] {
         # NOTE : the URL's don't work because of the & in them
         # doesn't work well when we exec the call to browsers
         # and if we follow spec and esacpe them with %26 then
         # the cgi script on the other end pukes so we will
         # just do an inline /userinfo when they are clicked
         .names insert end "$name" [list NICK URL URL-[incr ::URLID]] "\n"
         .names tag bind URL-$::URLID <1> [list msgSend "/userinfo $name"]
         incr i
     }
     .names insert 1.0 "$i Users Online\n\n" TITLE
     .names config -state disabled
 }

 proc invClr {clr {grays 1}} {
     # A little extra magic to avoid near shades of grey
     scan $clr %2x%2x%2x r g b
     set R [expr {(~$r)%256}]
     set G [expr {(~$g)%256}]
     set B [expr {(~$b)%256}]
     if {$grays && abs($R-$r) < 32 && abs($G-$g) < 32 && abs($B-$b) < 32} {
         set R [expr {($r+128)%256}]
         set G [expr {($g+128)%256}]
         set B [expr {($b+128)%256}]
     }
     return [format "%02x%02x%02x" $R $G $B]
 }

 proc getColor {name} {
     global Options
     if {[catch {
         set w $Options(Color,$name,Which)
         set clr $Options(Color,$name,$w)
     } err]} {
         set clr ""
         errLog "bad color name '$name'"
     }
     return $clr
 }

 proc parseData {rawHTML} {
     global Options
     # get body of data
     set clr ""
     if {[regexp -nocase -- \
                {<BODY.*?(?:BGColor=.([[:xdigit:]]{6}?))?>(.*?)<A\s+NAME="end">.*?</BODY>} \
                $rawHTML -> clr body]} {
         if {[string length $clr] && \
                   [string compare $Options(Color,MainBG,Web) $clr]} {
             set iclr [invClr $clr]
             set Options(Color,MainBG,Web) $clr
             set Options(Color,MainFG,Web) $iclr
             .txt config -background "#[getColor MainBG]" \
                   -foreground "#[getColor MainFG]"
         }
         # split into "lines"
         set dataList {}
         foreach item [::textutil::splitx [string trim $body] \
                             {[\s\n]*<BR>\n*}] {
             set item [string trimright $item]
             if {[string length $item]} {
                 lappend dataList $item
             }
         }
         set newList [getRecentLines $dataList]
         addNewLines $newList
     } else {
         errLog "No BODY found in HTML page"
     }
 }

 proc getRecentLines {input} {
     global Options
     set Found 0
     set mark 0
     set end [lindex $Options(History) end]
     set len [llength $Options(History)]
     while {[set idx [lsearch -exact [lrange $input $mark end] $end]] >= 0} {
         set num [expr {$mark + $idx}]
         set back [expr {$len - $num - 1}]
         set l1 [join [lrange $input 0 $num] +]
         set l2 [join [lrange $Options(History) $back end] +]
         set mark [incr num]
         if {[string equal $l1 $l2]} {
             set Found $mark
         }
         update idletasks
     }
     return [lrange $input $Found end]
 }

 array set RE {
     HelpStart {^<FONT COLOR="(.+?)"><B>\[(.+?)\]</B>(.*)$}
     MultiStart {^<FONT COLOR="(.+?)"><B>(\S+?)</B>:(.*?)$}
     SectEnd {^(.*)</FONT>$}
     Color {^<FONT COLOR="(.+?)">(.*?)</FONT>$}
     Message {^<B>(\S+?)</B>:(.+?)$}
     Help {^<B>\[(.+?)\]</B>(.*)$}
     Action {^<B>\*\s+(\S+)\s+(.+)</B>$}
     System {^<B>(.*)</B>$}
     Memo {^<B>\[MEMO\]</B>(.*)$}
 }
 proc addNewLines {input} {
     global Options RE

     set inHelp 0
     set inMsg 0
     foreach line $input {
         lappend Options(History) $line
         # only need enough history for matching new data
         set Options(History) [lrange $Options(History) end-50 end]
         # see if color is defined & strip it off
         if {[regexp -nocase -- $RE(Color) $line -> clr text]} {
             set line $text
             set color $clr
         } else {
             set color ""
         }
         # check what kind of line it is
         if $inHelp {
             if {[regexp -nocase -- $RE(SectEnd) $line -> text]} {
                 lappend helpLines $text
                 set inHelp 0
                 addHelp $helpColor $helpName [join $helpLines \n]
             } else {
                 lappend helpLines [string trimright $line]
             }
         } elseif $inMsg {
             if {[regexp -nocase -- $RE(SectEnd) $line -> text]} {
                 lappend msgLines [string trimright $text]
                 set inMsg 0
                 addMessage $nickColor $nick [join $msgLines \n]
             } else {
                 lappend msgLines [string trimright $line]
             }
         } else {
             if {[regexp -nocase -- $RE(HelpStart) $line -> clr name str]} {
                 set inHelp 1
                 set helpColor $clr
                 set helpName $name
                 set helpLines [list $str]
             } elseif {[regexp -nocase -- $RE(MultiStart) $line \
                              -> clr name str]} {
                 set inMsg 1
                 set nickColor $clr
                 set nick $name
                 set msgLines [list [string trimright $str]]
             } elseif {[regexp -nocase -- $RE(Memo) $line -> str]} {
                 showMemo $color [string trim $str]
             } elseif {[regexp -nocase -- $RE(Message) $line -> nick str]} {
                 addMessage $color $nick [string trim $str]
             } elseif {[regexp -nocase -- $RE(Help) $line -> name str]} {
                 addHelp $color $name [string trim $str]
             } elseif {[regexp -nocase -- $RE(Action) $line -> nick str]} {
                 addAction $color $nick $str
             } elseif {[regexp -nocase -- $RE(System) $line -> str]} {
                 addSystem $str
             } else {
                 errLog "Didn't recognize - '$line' - assume help"
                 addHelp $color "" [string trim $line]
             }
         }
     }
 }

 proc stripStr {str} {
     # remove any remaing tags
     regsub -all -nocase "<.*?>" $str {} tmp
     # replace html escapes with real chars
     return [::htmlparse::mapEscapes $tmp]
 }

 proc parseStr {str} {
     # get href info return list of str link pairs
     set sList {}
     while {[regexp -nocase -- {^(.*?)<A.*?HREF="(.+?)".*?>(.*?)</A>(.*?)$} \
                   $str -> pre url link post]} {
         if {[string length $pre]} {
             lappend sList [stripStr $pre] ""
         }
         lappend sList [stripStr $link] $url
         set str $post
     }
     if {[string length $str]} {
         lappend sList [stripStr $str] ""
     }
     return $sList
 }

 proc checkNick {nick clr} {
     global Options
     if {[string equal $clr ""]} {
         set clr [getColor MainFG]
     }
     if {[lsearch $Options(NickList) $nick] < 0} {
         lappend Options(NickList) $nick
         set Options(Color,$nick,Web) $clr
         set Options(Color,$nick,Inv) [invClr $clr]
         set Options(Color,$nick,Mine) $clr
         set Options(Color,$nick,Which) Web
         .mb.mnu delete 0 end
         .mb.mnu add command -label "All Users" \
               -command [list set Options(MsgTo) "All Users"]
         foreach nk [lsort $Options(NickList)] {
             .mb.mnu add command -label $nk \
                   -command [list set Options(MsgTo) $nk]
             .txt tag config NICK-$nk -foreground "#[getColor $nk]"
         }
         set wid [expr {[font measure NAME $nick] + 10}]
         if {$wid > $Options(Offset)} {
             set Options(Offset) $wid
             .txt config -tabs [list $wid l]
             .txt tag config MSG -lmargin2 [incr wid 20]
         }
     }
     set old [getColor $nick]
     if {[string compare $Options(Color,$nick,Web) $clr]} {
         # new color
         set Options(Color,$nick,Web) $clr
         set Options(Color,$nick,Inv) [invClr $clr]
         .txt tag config NICK-$nick -foreground "#[getColor $nick]"
     }
 }
 proc addMessage {clr nick str} {
     global Options
     checkNick $nick $clr
     .txt config -state normal
     .txt insert end $nick [list NICK NICK-$nick] "\t"
     foreach {str url} [parseStr $str] {
         regsub -all "\n" $str "\n\t" str
         if {$url == ""} {
             .txt insert end "$str " [list MSG NICK-$nick]
         } else {
             .txt insert end "$str " \
                   [list MSG NICK-$nick URL URL-[incr ::URLID]]
             .txt tag bind URL-$::URLID <1> [list gotoURL $url]
         }
     }
     .txt insert end "\n"
     .txt config -state disabled
     if {$Options(AutoScroll)} { .txt see end }
 }
 proc evalSelection {} {
     if {
         ![catch {selection get} script] &&
         [info complete $script]
     } then {
         uplevel #0 $script
     } else {
         tk_messageBox -message "The pasted script was not complete or there was nothing selected"
     }
 }

 proc findExecutable {progname varname} {
     upvar 1 $varname result
     set progs [auto_execok $progname]
     if {[llength $progs]} {
         set result [lindex $progs 0]
     }
     return [llength $progs]
 }

 proc gotoURL {url} {
     # this can take a bit
     . config -cursor watch
     .txt config -cursor watch
     update
     if [regexp -nocase -- {&url=(.*)} $url -> trueUrl] {
         # this was a redirect - just get final destination
         set url $trueUrl
     } elseif [regexp -nocase -- {^chat} $url] {
         # this is a relative url
         set url "http://purl.org/mini/cgi-bin/$url"
     } else {
         # assume a raw url
     }
     global tcl_platform env
     # this code from  http://purl.org/mini/tcl/557.html
     switch $tcl_platform(platform) {
         "unix" {
             expr {
                   [info exists env(BROWSER)] ||
                   [findExecutable netscape       env(BROWSER)] ||
                   [findExecutable iexplorer      env(BROWSER)] ||
                   [findExecutable $env(NETSCAPE) env(BROWSER)] ||
                   [findExecutable lynx           env(BROWSER)]
               }
             # lynx can also output formatted text to a variable
             # with the -dump option, as a last resort:
             # set formatted_text [ exec lynx -dump $url ] - PSE
             if {[catch {exec $env(BROWSER) -remote $url}]} {
                 # perhaps browser doesn't understand -remote flag
                 if {[catch {exec $env(BROWSER) $url &} emsg]} {
                     tk_messageBox -message "Error displaying $url in browser\n$emsg"
                 }
             }
         }
         "windows" {
             if [catch {eval exec [auto_execok start] [list $url] &} emsg] {
                 tk_messageBox -message "Error displaying $url in browser\n$emsg"
             }
         }
         "macintosh" {
             if {0 == [info exists env(BROWSER)]} {
                 set env(BROWSER) "Browse the Internet"
             }
             if {[catch {
                 AppleScript execute\
                       "tell application \"$env(BROWSER)\"
                          open url \"$url\"
                      end tell
                 "} emsg]
             } then {
                 tk_messageBox -message "Error displaying $url in browser\n$emsg"
             }
         }
     } ;## end of switch
     . config -cursor {}
     .txt config -cursor left_ptr
 }

 proc addAction {clr nick str} {
     global Options
     checkNick $nick $clr
     .txt config -state normal
     .txt insert end "\t* $nick " [list NICK NICK-$nick]
     foreach {str url} [parseStr $str] {
         regsub -all "\n" $str "\n\t" str
         if {[string equal $url ""]} {
             .txt insert end "$str " [list MSG NICK-$nick ACTION]
         } else {
             .txt insert end "$str " \
                   [list MSG NICK-$nick ACTION URL URL-[incr ::URLID]]
             .txt tag bind URL-$::URLID <1> [list gotoURL $url]
         }
     }
     .txt insert end "\n"
     .txt config -state disabled
     if {$Options(AutoScroll)} { .txt see end }
 }

 proc addSystem {str} {
     global Options
     .txt config -state normal
     .txt insert end "\t$str\n" [list MSG SYSTEM]
     .txt config -state disabled
     if {$Options(AutoScroll)} { .txt see end }
 }

 proc addUnknown {str} {
     global Options
 }

 proc showMemo {clr str} {
     set memo [stripStr $str]
     if {[regexp -nocase -- {(Memo from \S+? \(.+?\)):(.*?)$} \
                $memo -> who what]} {
         tk_messageBox -title $who -message $what
     } elseif {[regexp -nocase -- {Memo for} $memo]} {
         # no pop-=up
     } else {
         tk_messageBox -title Memo -message $mem
     }
     addHelp $clr MEMO $str
 }

 proc addHelp {clr name str} {
     global Options
     if {[lsearch -exact $Options(NickList) $name] >= 0} {
         # this is an incoming private message
         addAction $clr $name " whispers: $str"
         return
     }
     if {[string match "->*" $name]} {
         # an outgoing private message
         addAction $clr $Options(Username) " whispered to [string range $name 2 end]: $str"
         return
     }
     if {$clr != ""} {
         .txt tag config HELP -foreground "#$clr"
     }
     set jump $Options(AutoScroll)
     .txt config -state normal
     .txt insert end "$name\t" [list HELP NICK]
     foreach {str url} [parseStr $str] {
         regsub -all "\n" $str "\n\t" str
         if {[string equal $url ""]} {
             .txt insert end "$str " [list MSG HELP]
         } else {
             .txt insert end "$str " [list MSG HELP URL URL-[incr ::URLID]]
             .txt tag bind URL-$::URLID <1> [list gotoURL $url]
         }
     }
     .txt insert end "\n"
     .txt config -state disabled
     if $jump { .txt see end }
 }

 proc createFonts {} {
     font create FNT  -family helvetica -size -12 -weight normal -slant roman
     font create ACT  -family helvetica -size -12 -weight normal -slant italic
     font create NAME -family helvetica -size -12 -weight bold   -slant roman
     font create SYS  -family helvetica -size -12 -weight bold   -slant italic
 }

 proc createGUI {} {
     global Options

     wm title . "Tcl'ers Chat"
     wm withdraw .
     wm protocol . WM_DELETE_WINDOW quit

     createFonts

     menu .mbar -type menubar
     . config -menu .mbar

     .mbar add cascade -label File -menu [menu .mbar.file -tearoff 0]
     .mbar add cascade -label Edit -menu [menu .mbar.edit -tearoff 0]

     ## File Menu
     ##
     set m .mbar.file
     $m add checkbutton -label Pause \
           -variable ::wikichat::pause \
           -command { pause $::wikichat::pause }
     $m add command -label Logout -command logonScreen
     $m add separator
     $m add command -label Exit -command quit

     ## Edit Menu
     ##
     set m .mbar.edit
     $m add command -label Options... \
           -state disabled \
           -command changeSettings
     $m add command -label "My Color" \
           -command ::wikichat::ChooseColor
     $m add cascade -label "Font Name" -menu $m.fontName
     $m add cascade -label "Font Size" -menu $m.fontSize
     $m add separator
     if {[string equal "windows" $::tcl_platform(platform)]} {
         set ::wikichat::_console 0
         $m add checkbutton -label "Debug Console" \
               -variable ::wikichat::_console \
               -command {
                   if {$::wikichat::_console} { console show } else { console hide }
               }
     }

     ## Font Menus
     ##
     set m [menu .mbar.edit.fontName -tearoff 0]
     foreach name [lsort [font families]] {
         $m add radiobutton -label $name \
               -var ::wikichat::_font \
               -val $name \
               -command [list ::wikichat::ChangeFont -family $name]
     }
     set m [menu .mbar.edit.fontSize -tearoff 0]
     foreach sz {8 10 12 14 16 18 24 28 36} {
         $m add radiobutton -label $sz \
               -var ::wikichat::_fontsize \
               -val $sz \
               -command [list ::wikichat::ChangeFont -size $sz]
     }

     text .txt -background "#[getColor MainBG]" \
           -foreground "#[getColor MainFG]" \
           -font FNT -relief sunken -bd 2 -wrap word \
           -yscroll "scroll_set .sbar" \
           -state disabled -cursor left_ptr -height 1
     scrollbar .sbar -command ".txt yview"
     text .names -background "#[getColor MainBG]" \
           -foreground "#[getColor MainFG]" \
           -relief sunken -bd 2 -width 8 -font FNT -state disabled \
           -cursor left_ptr -height 1
     button .ml -text "More >>>" -command showExtra
     entry .eMsg
     bind .eMsg <Return> userPost
     bind .eMsg <KP_Enter> userPost
     text .tMsg -height 6 -font FNT
     button .post -text Post -command userPost
     menubutton .mb -indicator on -relief raised -bd 2 \
           -menu .mb.mnu -textvar Options(MsgTo)
     set Options(MsgTo) "All Users"
     menu .mb.mnu -tearoff 0
     .mb.mnu add command -label "All Users" \
           -command [list set Options(MsgTo) "All Users"]
     .txt tag config MSG -lmargin2 50
     .txt tag config NICK -font NAME
     .txt tag config ACTION -font ACT
     .txt tag config SYSTEM -font SYS
     .txt tag config URL -underline 1
     .txt tag bind URL <Enter> ".txt config -cursor hand2"
     .txt tag bind URL <Leave> ".txt config -cursor {}"
     .names tag config NICK -font NAME
     .names tag config TITLE -font SYS -justify center
     .names tag config URL -underline 1
     .names tag bind URL <Enter> ".names config -cursor hand2"
     .names tag bind URL <Leave> ".names config -cursor {}"

     foreach nick [lsort $Options(NickList)] {
         .mb.mnu add command -label $nick \
               -command [list set Options(MsgTo) $nick]
         .txt tag config NICK-$nick -foreground "#[getColor $nick]"
         set wid [expr [font measure NAME $nick] + 10]
         if {$wid > $Options(Offset)} {
             set Options(Offset) $wid
             .txt config -tabs [list $wid l]
             .txt tag config MSG -lmargin2 [incr wid 20]
         }
     }

     grid .txt   -   .sbar .names    -  -padx 1 -pady 2 -sticky news
     grid .ml .eMsg    -   .post  .mb -padx 2 -pady 3 -sticky ew
     grid columnconfigure . 1 -weight 1
     grid rowconfigure . 0 -weight 1
     wm geometry . 600x500
     wm deiconify .
 }

 proc userPost {} {
     global Options
     if [winfo ismapped .eMsg] {
         set str [.eMsg get]
     } else {
         set str [.tMsg get 1.0 end]
     }
     set msg [string trim $str]
     if [string equal $msg ""] {
         return
     }
     if [string equal $Options(MsgTo) "All Users"] {
         msgSend $msg
     } else {
         msgSend $msg $Options(MsgTo)
     }
     .eMsg delete 0 end
     .tMsg delete 1.0 end
 }

 proc hideExtra {} {
     grid remove .tMsg
     grid config .eMsg -row 1 -column 1 -columnspan 2 -sticky ew
     .ml config -text "More >>>" -command showExtra
 }
 proc showExtra {} {
     grid remove .eMsg
     grid config .tMsg -row 1 -column 1 -columnspan 2 -sticky ew
     .ml config -text "Less <<<" -command hideExtra
 }
 proc logonScreen {} {
     global Options LOGON
     pause on 0
     if {![winfo exists .logon]} {
         toplevel .logon -class dialog
         wm withdraw .logon
         wm transient .logon .
         wm title .logon "Logon to the Tcl'ers Chat"
         checkbutton .logon.prx -text "Use Proxy" -var Options(UseProxy)
         label .logon.lph -text "Proxy Host"
         label .logon.lpp -text "Proxy Port"
         entry .logon.eph -textvar Options(ProxyHost)
         entry .logon.epp -textvar Options(ProxyPort)
         label .logon.lpan -text "Proxy Auth Username"
         label .logon.lpap -text "Proxy Auth Password"
         entry .logon.epan -textvar Options(ProxyUsername)
         entry .logon.epap -textvar Options(ProxyPassword) -show {*}
         label .logon.lnm -text "Chat Username"
         label .logon.lpw -text "Chat Password"
         entry .logon.enm -textvar Options(Username)
         entry .logon.epw -textvar Options(Password) -show *
         checkbutton .logon.rpw -text "Remember Chat Password" -var Options(SavePW)
         checkbutton .logon.atc -text "Auto-connect" -var Options(AutoConnect)
         button .logon.ok -text "Logon" -command "set LOGON 1"
         button .logon.cn -text "Quit" -command quit
         trace variable Options(UseProxy) w optSet
         trace variable Options(SavePW) w optSet
         grid .logon.prx - - -sticky w -pady 3
         grid  x .logon.lph .logon.eph -sticky w -pady 3
         grid  x .logon.lpp .logon.epp -sticky w -pady 3
         grid  x .logon.lpan .logon.epan -sticky w -pady 3
         grid  x .logon.lpap .logon.epap -sticky w -pady 3
         grid .logon.lnm .logon.enm - -sticky ew -pady 5
         grid .logon.lpw .logon.epw - -sticky ew
         grid x .logon.rpw  - -sticky w -pady 3 -pady 3
         grid x .logon.atc  - -sticky w -pady 3
         grid .logon.ok - .logon.cn -sticky {} -pady 10
         wm resizable .logon 0 0
     }
     optSet
     wm deiconify .logon
     tkwait visibility .logon
     grab .logon
     vwait LOGON
     grab release .logon
     wm withdraw .logon
     if {$Options(UseProxy)} {
         ::http::config -proxyhost $Options(ProxyHost) \
               -proxyport $Options(ProxyPort)
     }
     # connect
     logonChat
 }

 proc optSet {args} {
     global Options
     if $Options(UseProxy) {
         set s normal
     } else {
         set s disabled
     }
     foreach w {lph lpp eph epp lpan epan lpap epap} {
         .logon.$w config -state $s
     }
     if $Options(SavePW) {
         .logon.atc config -state normal
     } else {
         .logon.atc config -state disabled
         set Options(AutoConnect) 0
     }
 }

 proc changeSettings {} {
     tk_messageBox -message "Changing font/colors coming soon!"
 }

 proc quit {} {
     set q "Are you sure you want to quit?"
     set a [tk_messageBox -type yesno -message $q]
     if {[string equal $a "yes"]} {
         saveRC
         exit
     }
 }

 proc saveRC {} {
     global Options
     if [info exists ::env(HOME)] {
         set rcfile [file join $::env(HOME) .tkchatrc]
         array set tmp [array get Options]
         set ignore {History FetchTimerID OnlineTimerID FetchToken OnlineToken ProxyPassword}
         if { ! $tmp(SavePW) } {
             lappend ignore Password
         }
         foreach idx $ignore {
             catch {unset tmp($idx)}
         }
         if {![catch {open $rcfile w} fd]} {
             puts $fd "# Auto-generated file: DO NOT MUCK WITH IT!"
             puts $fd [list array set Options [array get tmp]]
             puts $fd "# Auto-generated file: DO NOT MUCK WITH IT!"
             close $fd
         }
     }
 }

 proc scroll_set {sbar f1 f2} {
     global Options
     $sbar set $f1 $f2
     if {[string equal "$f1$f2" "01"]} {
         grid remove $sbar
     } else {
         grid $sbar
     }
     set Options(AutoScroll) [string equal $f2 1]
 }

 proc init {} {
     global Options
     set ::URLID 0
     # set intial defaults
     set ::wikichat::pause 0
     array set Options {
         URL  http://purl.org/mini/cgi-bin/chat.cgi
         URL2  http://purl.org/mini/cgi-bin/chat2.cgi
         UseProxy 0
         ProxyHost ""
         ProxyPort ""
         Username ""
         Password ""
         SavePW  0
         MyColor  000000
         FetchTimerID -1
         OnlineTimerID -1
         AutoConnect 0
         RefreshMS 30000
         NickList {}
         History  {}
         AutoScroll 0
     }
     foreach {name clr} { MainBG FFFFFF MainFG 000000 } {
         set Options(Color,$name,Web)   $clr
         set Options(Color,$name,Mine)  $clr
         set Options(Color,$name,Which) Web
     }

     # load RC file if it exists
     if {[info exists ::env(HOME)]} {
         if {[file readable [set rcfile [file join $::env(HOME) .tkchatrc]]]} {
             catch {source $rcfile}
         }
     }
     set Options(Offset) 50
     catch {unset Options(FetchToken)}
     catch {unset Options(OnlineToken)}
     set Options(History) {}

     # build screen
     createGUI

     if {$Options(UseProxy)} {
         ::http::config -proxyhost $Options(ProxyHost) \
               -proxyport $Options(ProxyPort)
     }
     # connect
     if {$Options(AutoConnect)} {
         logonChat
     } else {
         logonScreen
     }
 }

 proc ::wikichat::ChooseColor {} {
     set tmp [tk_chooseColor \
                    -title "Select Your User Color" \
                    -initialcolor \#$::Options(MyColor)]
    if {$tmp != ""} {
        set ::Options(MyColor) [string range $tmp 1 end]
    }
 }

 proc ::wikichat::ChangeFont {opt val} {
    foreach font [font names] {
        font configure $font $opt $val
    }
 }

 if {![info exists ::URLID]} {
    init
 }

I've added a few lines to make this speak new messages via the festival synthesiser. It doesn't do it robustly as yet (you'll need festival installed) but as a quick (1min) hack it's got heaps of cool points...

 set festival [open "|festival --pipe" w]
 proc say { message } {
    global festival

    # remove quotes
    regsub -all {\"} $message {} message2

    puts $message2
    puts $festival "(SayText \"$message2\")"
    flush $festival
 }

Then add a modified version of addMessage:

 proc addMessage {clr nick str} {
     global Options
     checkNick $nick $clr
     .txt config -state normal
     .txt insert end $nick [list NICK NICK-$nick] "\t"
     foreach {str url} [parseStr $str] {
         regsub -all "\n" $str "\n\t" str
         if {$url == ""} {
             say "$str"
             .txt insert end "$str " [list MSG NICK-$nick]
         } else {
             say "$str"
             .txt insert end "$str " \
                     [list MSG NICK-$nick URL URL-[incr ::URLID]]
             .txt tag bind URL-$::URLID <1> [list gotoURL $url]
         }
     }
     .txt insert end "\n"
     .txt config -state disabled
     if {$Options(AutoScroll)} { .txt see end }
 }

I might fix addMessage to add a general new-message-hook callback so that this could be a loadable plugin. Steve Cassidy


Ideas for expansion:

   - Query userinfo and display images if registered.
   - Memo handling
   - Text search in the page
   - Optionally filter out the entered/left messages
   - Optionally save to file, ability to load the data file

Please consider registering your expansion ideas as Feature Requests:

http://sf.net/tracker/?atid=362883&group_id=12883&func=browse 3d?d?


[ Category Application | Category GUI | Category Internet | Category Tcler's Wiki ]