Fossil SCM

Fossil chat client (Initial commit)

mjanssen 2007-09-24 21:03 trunk
Commit e202319ebbdb39853a6905d98422e719011dbba9
Parent aad573b31cde9df…
1 file changed +171
+ tools/fossil_chat.tcl
A tools/fossil_chat.tcl
+171
--- a/tools/fossil_chat.tcl
+++ b/tools/fossil_chat.tcl
@@ -0,0 +1,171 @@
1
+#!/home/drh/bin/tobe
2
+#
3
+# Simple chat client for Tcl/Tk.
4
+#
5
+package require Tk
6
+
7
+set SERVERHOST fossil-scm.hwaci.com
8
+# set SERVERHOST 127.0.0.1
9
+#set SERVERHOST 64.5.53.192
10
+set SERVERPORT 8615
11
+
12
+# Setup the user interface
13
+wm title . Fossil-Chat
14
+wm iconname . [wm title .]
15
+
16
+set ::PRIVATE 0
17
+
18
+menu .mb -type menubar
19
+if {$tcl$tcl_platform(os)!="Darwin"} {
20
+ pack .mb -side top -fill x
21
+} else {
22
+ . config -menu .mb
23
+}
24
+.mb add cascade -label File -underline 0 -menu .mb.file
25
+menu .mb.file -tearoff 0
26
+.mb.file add command -label Send -command send_message
27
+.mb.file add command -label {Remove older messages} -command ccheckbutton -label
28
+.mb.file add separator
29
+.mb.file add command -label {Exit} -command exit
30
+
31
+frame .who
32
+pack .who -side right -anchor n -fill y
33
+label .who.title -text {Users: }
34
+pack .who.title -side top -anchor nw
35
+label .who.listenvjustify left -text {}
36
+pack .who el .who.title -text {Userho.list -side top -anchor nw -expand 1 -padx 5
37
+label .who.time -text {} -justify right
38
+proc uenv(USERet now [clock seconds]
39
+ set time [clock format $now -format %H:%M -gmt 1]
40
+ .who.time config -text "UTC: $time"
41
+}
42
+update_time
43
+pack .who.time -side bottom -anchor sw
44
+
45
+frame .input
46
+pack .input -side bottom -fill x
47
+text .input.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 3 \
48
+ -wrap word -yscrollcommand [list .input.sb set] -takefocus 1
49
+bind .input.t <Key-Return> {send_message; break}
50
+pack .input.t -side left -fill both -expand 1
51
+scrollbar .input.sb -orient vertical -command [list .input.t yview]
52
+pack .input.sb -side left -fill y
53
+
54
+frame .msg
55
+pack .msg -side top -fill both -expand 1
56
+text .msg.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 20 \
57
+ -wrap word -yscrollcommand [list .msg.sb set] -takefocus 0
58
+bindtags .msg.t [list .msg.t . all]
59
+.msg.t tag config error -foreground red
60
+.msg.t tag config meta -foreground forestgreen
61
+.msg.t tag config norm -foreground black
62
+pack .msg.t -side left -fill both -expand 1
63
+scrollbar .msg.sb -orient vertical -command [list .msg.t yview]
64
+pack .msg.sb -side left -fill y
65
+
66
+update
67
+
68
+# Send periodic messages to keep the TCP/IP link up
69
+#
70
+proc keep_alive {} {
71
+ global TIMER SOCKET
72
+ catch {after cancel $TIMER}
73
+ set TIMER [after 300000 keep_alive]
74
+ catch {puts $SOCKET noop; flush $SOCKET}
75
+}
76
+
77
+# Connect to the server
78
+proc connect {} {
79
+ global SOCKET tcl_platform
80
+ catch {close $SOCKET}
81
+ if {[catch {
82
+ if {$::PROXYHOST ne {}} {
83
+ set SOCKET [socket $::PROXYHOST $::PROXYPORT]
84
+ puts $SOCKET
85
+}
86
+
87
+# Prompt the user to select a file from the disk. Then send that
88
+# file to all chat participants.
89
+#
90
+proc send_file {} {
91
+ global SOCKET
92
+ set openfile [tk_getOpenFile]
93
+ if {$openfile==""} return
94
+ set f [open $openfile]
95
+ fconfigure $f -translation binary
96
+ set data [read $f]
97
+ close $f
98
+ puts $SOCKET [list file [file tail $openfile] [encode $data]]
99
+ flush $SOCKET
100
+ set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
101
+ .msg.t insert end "\[$time\] sent file [file tail $openfile]\
102
+ - [string length $data] bytes\n" meta
103
+ .msg.t see end
104
+}
105
+
106
+# Save the named file to the disk.
107
+#
108
+ proc save_file {filename} {
109
+ global FILES
110
+ set savefile [tk_getSaveFile -initialfile $filename]
111
+ if {$savefile==""} return
112
+ set f [open $savefile w]
113
+ fconfigure $f -translation binary
114
+ puts -nonewline $f [decode $FILES($filename)]
115
+ close $f
116
+}
117
+
118
+# Handle a "file" message from the chat server.
119
+#
120
+proc handle_file {from filename data} {
121
+ global FILES
122
+ foreach prior [array names FILES] {
123
+ if {$filename==$prior} break
124
+ }
125
+ if {![info exists prior] || $filename!=$prior} {
126
+ .mb.files add command -label "Save \"$filename\"" \
127
+ -command [list save_file $filename]
128
+ }
129
+ set FILES($filename) $data
130
+ .mb.files ent e
131
+ set now [clock seconds[clock seconds] -format {%H:%M} -gmt 1]
132
+ .msg.t insert end "\[$time $from\] " meta "File: \"$filename\"\n" norm
133
+ .msg.t see end
134
+}
135
+
136
+# Handle input from the server
137
+#
138
+proc handle_input {} {
139
+ global SOCKET
140
+ if {[eof $SOCKET]} {
141
+ disconnect
142
+ return
143
+ }
144
+ set line [gets $SOCKET]
145
+ if {$line==""} return
146
+ set cmd [lindex $line 0]
147
+ if {$cmd=="userlist"} {
148
+ set ulist {}
149
+ foreach u [lrange $line 1 end] {
150
+ append ulist $u\n
151
+ }
152
+ .who.list config -text [string trim $ulist]
153
+ } elseif {$cmd=="message"} {
154
+ set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
155
+ set from [lindex $line 1]
156
+ .msg.t insert end "\[$time $from\] " meta [lindex $line 2]\n norm
157
+ .msg.t see end
158
+ bell
159
+ wm deiconify .
160
+ update
161
+ raise .
162
+ } elseif {$cmd=="noop"} {
163
+ # do nothing
164
+ } elseif {$cmd=="meta"} {
165
+ set now [clock seconds]
166
+ set time [clock format $now -format {%H:%M} -gmt 1]
167
+ .msg.t insert end "\[$time\] ndex $line 1]\n" meta
168
+lose $f
169
+}
170
+
171
+# Hand
--- a/tools/fossil_chat.tcl
+++ b/tools/fossil_chat.tcl
@@ -0,0 +1,171 @@
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
 
--- a/tools/fossil_chat.tcl
+++ b/tools/fossil_chat.tcl
@@ -0,0 +1,171 @@
1 #!/home/drh/bin/tobe
2 #
3 # Simple chat client for Tcl/Tk.
4 #
5 package require Tk
6
7 set SERVERHOST fossil-scm.hwaci.com
8 # set SERVERHOST 127.0.0.1
9 #set SERVERHOST 64.5.53.192
10 set SERVERPORT 8615
11
12 # Setup the user interface
13 wm title . Fossil-Chat
14 wm iconname . [wm title .]
15
16 set ::PRIVATE 0
17
18 menu .mb -type menubar
19 if {$tcl$tcl_platform(os)!="Darwin"} {
20 pack .mb -side top -fill x
21 } else {
22 . config -menu .mb
23 }
24 .mb add cascade -label File -underline 0 -menu .mb.file
25 menu .mb.file -tearoff 0
26 .mb.file add command -label Send -command send_message
27 .mb.file add command -label {Remove older messages} -command ccheckbutton -label
28 .mb.file add separator
29 .mb.file add command -label {Exit} -command exit
30
31 frame .who
32 pack .who -side right -anchor n -fill y
33 label .who.title -text {Users: }
34 pack .who.title -side top -anchor nw
35 label .who.listenvjustify left -text {}
36 pack .who el .who.title -text {Userho.list -side top -anchor nw -expand 1 -padx 5
37 label .who.time -text {} -justify right
38 proc uenv(USERet now [clock seconds]
39 set time [clock format $now -format %H:%M -gmt 1]
40 .who.time config -text "UTC: $time"
41 }
42 update_time
43 pack .who.time -side bottom -anchor sw
44
45 frame .input
46 pack .input -side bottom -fill x
47 text .input.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 3 \
48 -wrap word -yscrollcommand [list .input.sb set] -takefocus 1
49 bind .input.t <Key-Return> {send_message; break}
50 pack .input.t -side left -fill both -expand 1
51 scrollbar .input.sb -orient vertical -command [list .input.t yview]
52 pack .input.sb -side left -fill y
53
54 frame .msg
55 pack .msg -side top -fill both -expand 1
56 text .msg.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 20 \
57 -wrap word -yscrollcommand [list .msg.sb set] -takefocus 0
58 bindtags .msg.t [list .msg.t . all]
59 .msg.t tag config error -foreground red
60 .msg.t tag config meta -foreground forestgreen
61 .msg.t tag config norm -foreground black
62 pack .msg.t -side left -fill both -expand 1
63 scrollbar .msg.sb -orient vertical -command [list .msg.t yview]
64 pack .msg.sb -side left -fill y
65
66 update
67
68 # Send periodic messages to keep the TCP/IP link up
69 #
70 proc keep_alive {} {
71 global TIMER SOCKET
72 catch {after cancel $TIMER}
73 set TIMER [after 300000 keep_alive]
74 catch {puts $SOCKET noop; flush $SOCKET}
75 }
76
77 # Connect to the server
78 proc connect {} {
79 global SOCKET tcl_platform
80 catch {close $SOCKET}
81 if {[catch {
82 if {$::PROXYHOST ne {}} {
83 set SOCKET [socket $::PROXYHOST $::PROXYPORT]
84 puts $SOCKET
85 }
86
87 # Prompt the user to select a file from the disk. Then send that
88 # file to all chat participants.
89 #
90 proc send_file {} {
91 global SOCKET
92 set openfile [tk_getOpenFile]
93 if {$openfile==""} return
94 set f [open $openfile]
95 fconfigure $f -translation binary
96 set data [read $f]
97 close $f
98 puts $SOCKET [list file [file tail $openfile] [encode $data]]
99 flush $SOCKET
100 set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
101 .msg.t insert end "\[$time\] sent file [file tail $openfile]\
102 - [string length $data] bytes\n" meta
103 .msg.t see end
104 }
105
106 # Save the named file to the disk.
107 #
108 proc save_file {filename} {
109 global FILES
110 set savefile [tk_getSaveFile -initialfile $filename]
111 if {$savefile==""} return
112 set f [open $savefile w]
113 fconfigure $f -translation binary
114 puts -nonewline $f [decode $FILES($filename)]
115 close $f
116 }
117
118 # Handle a "file" message from the chat server.
119 #
120 proc handle_file {from filename data} {
121 global FILES
122 foreach prior [array names FILES] {
123 if {$filename==$prior} break
124 }
125 if {![info exists prior] || $filename!=$prior} {
126 .mb.files add command -label "Save \"$filename\"" \
127 -command [list save_file $filename]
128 }
129 set FILES($filename) $data
130 .mb.files ent e
131 set now [clock seconds[clock seconds] -format {%H:%M} -gmt 1]
132 .msg.t insert end "\[$time $from\] " meta "File: \"$filename\"\n" norm
133 .msg.t see end
134 }
135
136 # Handle input from the server
137 #
138 proc handle_input {} {
139 global SOCKET
140 if {[eof $SOCKET]} {
141 disconnect
142 return
143 }
144 set line [gets $SOCKET]
145 if {$line==""} return
146 set cmd [lindex $line 0]
147 if {$cmd=="userlist"} {
148 set ulist {}
149 foreach u [lrange $line 1 end] {
150 append ulist $u\n
151 }
152 .who.list config -text [string trim $ulist]
153 } elseif {$cmd=="message"} {
154 set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
155 set from [lindex $line 1]
156 .msg.t insert end "\[$time $from\] " meta [lindex $line 2]\n norm
157 .msg.t see end
158 bell
159 wm deiconify .
160 update
161 raise .
162 } elseif {$cmd=="noop"} {
163 # do nothing
164 } elseif {$cmd=="meta"} {
165 set now [clock seconds]
166 set time [clock format $now -format {%H:%M} -gmt 1]
167 .msg.t insert end "\[$time\] ndex $line 1]\n" meta
168 lose $f
169 }
170
171 # Hand

Keyboard Shortcuts

Open search /
Next entry (timeline) j
Previous entry (timeline) k
Open focused entry Enter
Show this help ?
Toggle theme Top nav button