e202319ebb 2007-09-24  mjanssen: #!/home/drh/bin/tobe
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: # Simple chat client for Tcl/Tk.
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: package require Tk
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: set SERVERHOST fossil-scm.hwaci.com
e202319ebb 2007-09-24  mjanssen: # set SERVERHOST 127.0.0.1
e202319ebb 2007-09-24  mjanssen: #set SERVERHOST 64.5.53.192
e202319ebb 2007-09-24  mjanssen: set SERVERPORT 8615
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Setup the user interface
e202319ebb 2007-09-24  mjanssen: wm title . Fossil-Chat
e202319ebb 2007-09-24  mjanssen: wm iconname . [wm title .]
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: set ::PRIVATE 0
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: menu .mb -type menubar
e202319ebb 2007-09-24  mjanssen: if {$tcl_platform(platform)=="unix"} {
e202319ebb 2007-09-24  mjanssen:   pack .mb -side top -fill x
e202319ebb 2007-09-24  mjanssen: } else {
e202319ebb 2007-09-24  mjanssen:   . config -menu .mb
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: .mb add cascade -label File -underline 0 -menu .mb.file
e202319ebb 2007-09-24  mjanssen: menu .mb.file -tearoff 0
e202319ebb 2007-09-24  mjanssen: .mb.file add command -label Send -command send_message
e202319ebb 2007-09-24  mjanssen: .mb.file add command -label {Remove older messages} -command cleanup_record
e202319ebb 2007-09-24  mjanssen: .mb.file add checkbutton -label {Private} -variable PRIVATE
e202319ebb 2007-09-24  mjanssen: .mb.file add separator
e202319ebb 2007-09-24  mjanssen: .mb.file add command -label {Exit} -command exit
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: frame .who
e202319ebb 2007-09-24  mjanssen: pack .who -side right -anchor n -fill y
e202319ebb 2007-09-24  mjanssen: label .who.title -text {Users:      }
e202319ebb 2007-09-24  mjanssen: pack .who.title -side top -anchor nw
e202319ebb 2007-09-24  mjanssen: label .who.list -anchor w -justify left -text {}
e202319ebb 2007-09-24  mjanssen: pack .who.list -side top -anchor nw -expand 1 -padx 5
e202319ebb 2007-09-24  mjanssen: label .who.time -text {} -justify right
e202319ebb 2007-09-24  mjanssen: proc update_time {} {
e202319ebb 2007-09-24  mjanssen:   after 1000 update_time
e202319ebb 2007-09-24  mjanssen:   set now [clock seconds]
e202319ebb 2007-09-24  mjanssen:   set time1 [clock format [expr {$now-4*3600}] -format {%H:%M} -gmt 1]
e202319ebb 2007-09-24  mjanssen:   set time2 [clock format [expr {$now+10*3600}] -format {%H:%M} -gmt 1]
e202319ebb 2007-09-24  mjanssen:   set time3 [clock format $now -format %H:%M -gmt 1]
e202319ebb 2007-09-24  mjanssen:   .who.time config -text "AEST: $time2\nUTC: $time3\nEST: $time1"
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: update_time
e202319ebb 2007-09-24  mjanssen: pack .who.time -side bottom -anchor sw
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: frame .input
e202319ebb 2007-09-24  mjanssen: pack .input -side bottom -fill x
e202319ebb 2007-09-24  mjanssen: text .input.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 3 \
e202319ebb 2007-09-24  mjanssen:    -wrap word -yscrollcommand [list .input.sb set] -takefocus 1
e202319ebb 2007-09-24  mjanssen: bind .input.t <Key-Return> {send_message; break}
e202319ebb 2007-09-24  mjanssen: pack .input.t -side left -fill both -expand 1
e202319ebb 2007-09-24  mjanssen: scrollbar .input.sb -orient vertical -command [list .input.t yview]
e202319ebb 2007-09-24  mjanssen: pack .input.sb -side left -fill y
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: frame .msg
e202319ebb 2007-09-24  mjanssen: pack .msg -side top -fill both -expand 1
e202319ebb 2007-09-24  mjanssen: text .msg.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 20 \
e202319ebb 2007-09-24  mjanssen:    -wrap word -yscrollcommand [list .msg.sb set] -takefocus 0
e202319ebb 2007-09-24  mjanssen: bindtags .msg.t [list .msg.t . all]
e202319ebb 2007-09-24  mjanssen: .msg.t tag config error -foreground red
e202319ebb 2007-09-24  mjanssen: .msg.t tag config meta -foreground forestgreen
e202319ebb 2007-09-24  mjanssen: .msg.t tag config norm -foreground black
e202319ebb 2007-09-24  mjanssen: pack .msg.t -side left -fill both -expand 1
e202319ebb 2007-09-24  mjanssen: scrollbar .msg.sb -orient vertical -command [list .msg.t yview]
e202319ebb 2007-09-24  mjanssen: pack .msg.sb -side left -fill y
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: update
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Send periodic messages to keep the TCP/IP link up
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc keep_alive {} {
e202319ebb 2007-09-24  mjanssen:   global TIMER SOCKET
e202319ebb 2007-09-24  mjanssen:   catch {after cancel $TIMER}
e202319ebb 2007-09-24  mjanssen:   set TIMER [after 300000 keep_alive]
e202319ebb 2007-09-24  mjanssen:   catch {puts $SOCKET noop; flush $SOCKET}
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Connect to the server
e202319ebb 2007-09-24  mjanssen: proc connect {} {
e202319ebb 2007-09-24  mjanssen:   global SOCKET env
e202319ebb 2007-09-24  mjanssen:   catch {close $SOCKET}
e202319ebb 2007-09-24  mjanssen:   if {[catch {
e202319ebb 2007-09-24  mjanssen:     set SOCKET [socket $::SERVERHOST $::SERVERPORT]
e202319ebb 2007-09-24  mjanssen:     fconfigure $SOCKET -translation binary -blocking 0
e202319ebb 2007-09-24  mjanssen:     puts $SOCKET [list login $env(USER) fact,fuzz]
e202319ebb 2007-09-24  mjanssen:     flush $SOCKET
e202319ebb 2007-09-24  mjanssen:     fileevent $SOCKET readable handle_input
e202319ebb 2007-09-24  mjanssen:     keep_alive
e202319ebb 2007-09-24  mjanssen:   } errmsg]} {
e202319ebb 2007-09-24  mjanssen:     if {[tk_messageBox -icon error -type yesno -parent . -message \
e202319ebb 2007-09-24  mjanssen:            "Unable to connect to server.  $errmsg.\n\nTry again?"]=="yes"} {
e202319ebb 2007-09-24  mjanssen:       after 100 connect
e202319ebb 2007-09-24  mjanssen:     }
e202319ebb 2007-09-24  mjanssen:   }
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: connect
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Send the message text contained in the .input.t widget to the server.
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc send_message {} {
e202319ebb 2007-09-24  mjanssen:   set txt [.input.t get 1.0 end]
e202319ebb 2007-09-24  mjanssen:   .input.t delete 1.0 end
e202319ebb 2007-09-24  mjanssen:   regsub -all "\[ \t\n\f\r\]+" [string trim $txt] { } txt
e202319ebb 2007-09-24  mjanssen:   if {$txt==""} return
e202319ebb 2007-09-24  mjanssen:   global SOCKET
e202319ebb 2007-09-24  mjanssen:   if {$::PRIVATE} {
e202319ebb 2007-09-24  mjanssen:     puts $SOCKET [list private_message $txt [list dan drh]]
e202319ebb 2007-09-24  mjanssen:   } else {
e202319ebb 2007-09-24  mjanssen:     puts $SOCKET [list message $txt]
e202319ebb 2007-09-24  mjanssen:   }
e202319ebb 2007-09-24  mjanssen:   flush $SOCKET
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: .mb add cascade -label "Transfer" -underline 0 -menu .mb.files
e202319ebb 2007-09-24  mjanssen: menu .mb.files -tearoff 0
e202319ebb 2007-09-24  mjanssen: .mb.files add command -label "Send file..." -command send_file
e202319ebb 2007-09-24  mjanssen: .mb.files add command -label "Delete files" -command delete_files \
e202319ebb 2007-09-24  mjanssen:     -state disabled
e202319ebb 2007-09-24  mjanssen: .mb.files add separator
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Encode a string (possibly containing binary and \000 characters) into
e202319ebb 2007-09-24  mjanssen: # single line of text.
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc encode {txt} {
e202319ebb 2007-09-24  mjanssen:   return [string map [list % %25 + %2b " " + \n %0a \t %09 \000 %00] $txt]
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Undo the work of encode.  Convert an encoded string back into its original
e202319ebb 2007-09-24  mjanssen: # form.
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc decode {txt} {
e202319ebb 2007-09-24  mjanssen:   return [string map [list %00 \000 %09 \t %0a \n + " " %2b + %25 %] $txt]
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Delete all of the downloaded files we are currently holding.
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc delete_files {} {
e202319ebb 2007-09-24  mjanssen:   global FILES
e202319ebb 2007-09-24  mjanssen:   .mb.files delete 3 end
e202319ebb 2007-09-24  mjanssen:   array unset FILES
e202319ebb 2007-09-24  mjanssen:   .mb.files entryconfigure 1 -state disabled
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Prompt the user to select a file from the disk.  Then send that
e202319ebb 2007-09-24  mjanssen: # file to all chat participants.
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc send_file {} {
e202319ebb 2007-09-24  mjanssen:   global SOCKET
e202319ebb 2007-09-24  mjanssen:   set openfile [tk_getOpenFile]
e202319ebb 2007-09-24  mjanssen:   if {$openfile==""} return
e202319ebb 2007-09-24  mjanssen:   set f [open $openfile]
e202319ebb 2007-09-24  mjanssen:   fconfigure $f -translation binary
e202319ebb 2007-09-24  mjanssen:   set data [read $f]
e202319ebb 2007-09-24  mjanssen:   close $f
e202319ebb 2007-09-24  mjanssen:   if {$::PRIVATE} {
e202319ebb 2007-09-24  mjanssen:     puts $SOCKET [list private_file [file tail $openfile] [encode $data] \
e202319ebb 2007-09-24  mjanssen:         [list dan drh]]
e202319ebb 2007-09-24  mjanssen:   } else {
e202319ebb 2007-09-24  mjanssen:     puts $SOCKET [list file [file tail $openfile] [encode $data]]
e202319ebb 2007-09-24  mjanssen:   }
e202319ebb 2007-09-24  mjanssen:   flush $SOCKET
e202319ebb 2007-09-24  mjanssen:   set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
e202319ebb 2007-09-24  mjanssen:   .msg.t insert end "\[$time\] sent file [file tail $openfile]\
e202319ebb 2007-09-24  mjanssen:         - [string length $data] bytes\n" meta
e202319ebb 2007-09-24  mjanssen:   .msg.t see end
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Save the named file to the disk.
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen:  proc save_file {filename} {
e202319ebb 2007-09-24  mjanssen:   global FILES
e202319ebb 2007-09-24  mjanssen:   set savefile [tk_getSaveFile -initialfile $filename]
e202319ebb 2007-09-24  mjanssen:   if {$savefile==""} return
e202319ebb 2007-09-24  mjanssen:   set f [open $savefile w]
e202319ebb 2007-09-24  mjanssen:   fconfigure $f -translation binary
e202319ebb 2007-09-24  mjanssen:   puts -nonewline $f [decode $FILES($filename)]
e202319ebb 2007-09-24  mjanssen:   close $f
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Handle a "file" message from the chat server.
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc handle_file {from filename data} {
e202319ebb 2007-09-24  mjanssen:   global FILES
e202319ebb 2007-09-24  mjanssen:   foreach prior [array names FILES] {
e202319ebb 2007-09-24  mjanssen:     if {$filename==$prior} break
e202319ebb 2007-09-24  mjanssen:   }
e202319ebb 2007-09-24  mjanssen:   if {![info exists prior] || $filename!=$prior} {
e202319ebb 2007-09-24  mjanssen:     .mb.files add command -label "Save \"$filename\"" \
e202319ebb 2007-09-24  mjanssen:         -command [list save_file $filename]
e202319ebb 2007-09-24  mjanssen:   }
e202319ebb 2007-09-24  mjanssen:   set FILES($filename) $data
e202319ebb 2007-09-24  mjanssen:   .mb.files entryconfigure 1 -state active
e202319ebb 2007-09-24  mjanssen:   set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
e202319ebb 2007-09-24  mjanssen:   .msg.t insert end "\[$time $from\] " meta "File: \"$filename\"\n" norm
e202319ebb 2007-09-24  mjanssen:   .msg.t see end
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Handle input from the server
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc handle_input {} {
e202319ebb 2007-09-24  mjanssen:   global SOCKET
e202319ebb 2007-09-24  mjanssen:   if {[eof $SOCKET]} {
e202319ebb 2007-09-24  mjanssen:     disconnect
e202319ebb 2007-09-24  mjanssen:     return
e202319ebb 2007-09-24  mjanssen:   }
e202319ebb 2007-09-24  mjanssen:   set line [gets $SOCKET]
e202319ebb 2007-09-24  mjanssen:   if {$line==""} return
e202319ebb 2007-09-24  mjanssen:   set cmd [lindex $line 0]
e202319ebb 2007-09-24  mjanssen:   if {$cmd=="userlist"} {
e202319ebb 2007-09-24  mjanssen:     set ulist {}
e202319ebb 2007-09-24  mjanssen:     foreach u [lrange $line 1 end] {
e202319ebb 2007-09-24  mjanssen:       append ulist $u\n
e202319ebb 2007-09-24  mjanssen:     }
e202319ebb 2007-09-24  mjanssen:     .who.list config -text [string trim $ulist]
e202319ebb 2007-09-24  mjanssen:   } elseif {$cmd=="message"||$cmd=="private_message"} {
e202319ebb 2007-09-24  mjanssen:     set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
e202319ebb 2007-09-24  mjanssen:     set from [lindex $line 1]
e202319ebb 2007-09-24  mjanssen:     .msg.t insert end "\[$time $from\] " meta [lindex $line 2]\n norm
e202319ebb 2007-09-24  mjanssen:     .msg.t see end
e202319ebb 2007-09-24  mjanssen:     bell
e202319ebb 2007-09-24  mjanssen:     wm deiconify .
e202319ebb 2007-09-24  mjanssen:     update
e202319ebb 2007-09-24  mjanssen:     raise .
e202319ebb 2007-09-24  mjanssen:   } elseif {$cmd=="noop"} {
e202319ebb 2007-09-24  mjanssen:     # do nothing
e202319ebb 2007-09-24  mjanssen:   } elseif {$cmd=="meta"} {
e202319ebb 2007-09-24  mjanssen:     set now [clock seconds]
e202319ebb 2007-09-24  mjanssen:     set time [clock format $now -format {%H:%M} -gmt 1]
e202319ebb 2007-09-24  mjanssen:     .msg.t insert end "\[$time\] [lindex $line 1]\n" meta
e202319ebb 2007-09-24  mjanssen:     .msg.t see end
e202319ebb 2007-09-24  mjanssen:   } elseif {$cmd=="file"||$cmd=="private_file"} {
e202319ebb 2007-09-24  mjanssen:     if {[info commands handle_file]=="handle_file"} {
e202319ebb 2007-09-24  mjanssen:       handle_file [lindex $line 1] [lindex $line 2] [lindex $line 3]
e202319ebb 2007-09-24  mjanssen:     }
e202319ebb 2007-09-24  mjanssen:   }
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Handle a broken socket connection
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc disconnect {} {
e202319ebb 2007-09-24  mjanssen:   global SOCKET
e202319ebb 2007-09-24  mjanssen:   close $SOCKET
e202319ebb 2007-09-24  mjanssen:   set q [tk_messageBox -icon error -type yesno -parent . -message \
e202319ebb 2007-09-24  mjanssen:            "TCP/IP link lost.  Try to reconnet?"]
e202319ebb 2007-09-24  mjanssen:   if {$q=="yes"} {
e202319ebb 2007-09-24  mjanssen:     connect
e202319ebb 2007-09-24  mjanssen:   } else {
e202319ebb 2007-09-24  mjanssen:     exit
e202319ebb 2007-09-24  mjanssen:   }
e202319ebb 2007-09-24  mjanssen: }
e202319ebb 2007-09-24  mjanssen: 
e202319ebb 2007-09-24  mjanssen: # Remove all but the most recent 100 message from the message log
e202319ebb 2007-09-24  mjanssen: #
e202319ebb 2007-09-24  mjanssen: proc cleanup_record {} {
e202319ebb 2007-09-24  mjanssen:   .msg.t delete 1.0 {end -100 lines}
e202319ebb 2007-09-24  mjanssen: }