#!/bin/sh
# -*- tcl -*-
#
# CkChat: A minimalistic Ck front end to the Tcl'ers chat
# Inspired by TkChat
#
# Author: Michael A. Cleverly, michael@cleverly.com
#
# 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 "<" < \
">" > \
"&" & \
"<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
}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.
Getting started
Home • Recent changes • Help • Create new page • Search • Add comments
• Edit