Fossil SCM

Remove obsolete chat scripts from the tools/ folder.

drh 2021-02-06 09:24 trunk

Commit c2961945dfac0c7abb7e969690f14817a6b25c76626dabbb4f629bd00bff6e1b

Parent 1c33969bf4f87ce…

2 files changed -509 -257

- tools/chat.tcl - tools/fossil_chat.tcl

D tools/chat.tcl

-509

		--- a/tools/chat.tcl
		+++ b/tools/chat.tcl
		@@ -1,509 +0,0 @@
1		-#!/usr/bin/wapptclsh
2		-#
3		-# A chat program designed to run using the extcgi mechanism of Fossil.
4		-#
5		-encoding system utf-8
6		-
7		-# The name of the chat database file
8		-#
9		-proc chat-db-name {} {
10		- set x [wapp-param SCRIPT_FILENAME]
11		- set dir [file dir $x]
12		- set fn [file tail $x]
13		- return $dir/-$fn.db
14		-}
15		-
16		-# Verify permission to use chat. Return true if not authorized.
17		-# Return false if the Fossil user is allowed to access chat.
18		-#
19		-proc not-authorized {} {
20		- set cap [wapp-param FOSSIL_CAPABILITIES]
21		- return [expr {![string match i $cap]}]
22		-}
23		-
24		-# The default page.
25		-# Load the initial chat screen.
26		-#
27		-proc wapp-default {} {
28		- wapp-content-security-policy off
29		- wapp-trim {
30		- <div class="fossil-doc" data-title="Chat">
31		- }
32		- if {[not-authorized]} {
33		- wapp-trim {
34		- <h1>Not authorized</h1>
35		- <p>You must have privileges to use this chatroom</p>
36		- </div>
37		- }
38		- return
39		- }
40		- set scriptFile [wapp-param SCRIPT_FILENAME]
41		- set cgiFn [file tail $scriptFile]
42		- wapp-trim {
43		- <form accept-encoding="utf-8" id="chat-form">
44		- <div id='chat-input-area'>
45		- <div id='chat-input-line'>
46		- <input type="text" name="msg" id="sbox" placeholder="Type message here.">
47		- <input type="submit" value="Send">
48		- </div>
49		- <div id='chat-input-file'>
50		- <span>File:</span>
51		- <input type="file" name="file">
52		- </div>
53		- </div>
54		- </form>
55		- <hr>
56		- <span id='message-inject-point'><!--
57		- new chat messages get inserted immediately after this element
58		- --></span>
59		-
60		- </div><!-- .fossil-doc -->
61		- <hr>
62		- <p>
63		- <a href="%string($cgiFn)/env">CGI environment</a> \|
64		- <a href="%string($cgiFn)/self">Wapp script</a>
65		- <style>
66		-\#dialog {
67		- width: 97%;
68		-}
69		-\#chat-input-area {
70		- width: 100%;
71		- display: flex;
72		- flex-direction: column;
73		-}
74		-\#chat-input-line {
75		- display: flex;
76		- flex-direction: row;
77		- margin-bottom: 1em;
78		- align-items: center;
79		-}
80		-\#chat-input-line > input[type=submit] {
81		- flex: 1 5 auto;
82		- max-width: 6em;
83		-}
84		-\#chat-input-line > input[type=text] {
85		- flex: 5 1 auto;
86		-}
87		-\#chat-input-file {
88		- display: flex;
89		- flex-direction: row;
90		- align-items: center;
91		-}
92		-\#chat-input-file > input {
93		- flex: 1 0 auto;
94		-}
95		-span.at-name { /* for @USERNAME references */
96		- text-decoration: underline;
97		- font-weight: bold;
98		-}
99		-/* A wrapper for a single single message (one row of the UI) */
100		-.message-row {
101		- margin-bottom: 0.5em;
102		- border: none;
103		- display: flex;
104		- flex-direction: row;
105		- justify-content: flex-start;
106		- /*border: 1px solid rgba(0,0,0,0.2);
107		- border-radius: 0.25em;
108		- box-shadow: 0.2em 0.2em 0.2em rgba(0, 0, 0, 0.29);*/
109		- border: none;
110		-}
111		-/* Rows for the current user have the .user-is-me CSS class
112		- and get right-aligned. */
113		-.message-row.user-is-me {
114		- justify-content: flex-end;
115		- /background-color: #d2dde1;/
116		-}
117		-/* The content area of a message (the body element of a FIELDSET) */
118		-.message-content {
119		- display: inline-block;
120		- border-radius: 0.25em;
121		- border: 1px solid rgba(0,0,0,0.2);
122		- box-shadow: 0.2em 0.2em 0.2em rgba(0, 0, 0, 0.29);
123		- padding: 0.25em 1em;
124		- margin-top: -0.75em;
125		-}
126		-.message-row.user-is-me .message-content {
127		- background-color: #d2dde1;
128		-}
129		-/* User name for the post (a LEGEND element) */
130		-.message-row .message-user {
131		- background: inherit;
132		- border-radius: 0.25em 0.25em 0 0;
133		- padding: 0 0.5em;
134		- /text-align: left; Firefox requires the 'align' attribute /
135		- margin-left: 0.25em;
136		- padding: 0 0.5em 0em 0.5em;
137		- margin-bottom: 0.4em;
138		- background-color: #d2dde1;
139		-}
140		-/* Reposition "my" posts to the right */
141		-.message-row.user-is-me .message-user {
142		- /text-align: right; Firefox requires the 'align' attribute /
143		- margin-left: 0;
144		- margin-right: 0.25em;
145		-}
146		-</style>
147		- }
148		- set nonce [wapp-param FOSSIL_NONCE]
149		- set submiturl [wapp-param SCRIPT_NAME]/send
150		- set pollurl [wapp-param SCRIPT_NAME]/poll
151		- set downloadurl [wapp-param SCRIPT_NAME]/download
152		- set me [wapp-param FOSSIL_USER]
153		- wapp-trim {
154		-<script nonce="%string($nonce)">
155		-(function(){
156		- const form = document.querySelector('#chat-form');
157		- let mxMsg = 0;
158		- let _me = "%string($me)";
159		- form.addEventListener('submit',(e)=>{
160		- e.preventDefault();
161		- if( form.msg.value.length>0 \|\| form.file.value.length>0 ){
162		- fetch("%string($submiturl)",{
163		- method: 'POST',
164		- body: new FormData(form)
165		- });
166		- }
167		- form.msg.value = "";
168		- form.file.value = "";
169		- form.msg.focus();
170		- });
171		- const rxUrl = /\\b(?:https?\|ftp):\\/\\/\[a-z0-9-+&@\#\\/%?=~_\|!:,.;]*\[a-z0-9-+&@\#\\/%=~_\|]/gim;
172		- const rxAtName = /@\\w+/gmi;
173		- // ^^^ achtung, extra backslashes needed for the outer TCL.
174		- const textNode = (T)=>document.createTextNode(T);
175		-
176		- // Converts a message string to a message-containing DOM element
177		- // and returns that element, which may contain child elements.
178		- // If 2nd arg is passed, it must be a DOM element to which all
179		- // child elements are appended.
180		- const messageToDOM = function f(str, tgtElem){
181		- "use strict";
182		- if(!f.rxUrl){
183		- f.rxUrl = rxUrl;
184		- f.rxAt = rxAtName;
185		- f.rxNS = /\\S/;
186		- f.ce = (T)=>document.createElement(T);
187		- f.ct = (T)=>document.createTextNode(T);
188		- f.replaceUrls = function ff(sub, offset, whole){
189		- if(offset > ff.prevStart){
190		- f.accum.push((ff.prevStart?' ':'')+whole.substring(ff.prevStart, offset-1)+' ');
191		- }
192		- const a = f.ce('a');
193		- a.setAttribute('href',sub);
194		- a.setAttribute('target','_blank');
195		- a.appendChild(f.ct(sub));
196		- f.accum.push(a);
197		- ff.prevStart = offset + sub.length + 1;
198		- };
199		- f.replaceAtName = function ff(sub, offset,whole){
200		- if(offset > ff.prevStart){
201		- ff.accum.push((ff.prevStart?' ':'')+whole.substring(ff.prevStart, offset-1)+' ');
202		- }else if(offset && f.rxNS.test(whole[offset-1])){
203		- // Sigh: https://stackoverflow.com/questions/52655367
204		- ff.accum.push(sub);
205		- return;
206		- }
207		- const e = f.ce('span');
208		- e.classList.add('at-name');
209		- e.appendChild(f.ct(sub));
210		- ff.accum.push(e);
211		- ff.prevStart = offset + sub.length + 1;
212		- };
213		- }
214		- f.accum = []; // accumulate strings and DOM elements here.
215		- f.rxUrl.lastIndex = f.replaceUrls.prevStart = 0; // reset regex cursor
216		- str.replace(f.rxUrl, f.replaceUrls);
217		- // Push remaining non-URL part of the string to the queue...
218		- if(f.replaceUrls.prevStart < str.length){
219		- f.accum.push((f.replaceUrls.prevStart?' ':'')+str.substring(f.replaceUrls.prevStart));
220		- }
221		- // Pass 2: process @NAME references...
222		- // TODO: only match NAME if it's the name of a currently participating
223		- // user. Add a second class if NAME == current user, and style that one
224		- // differently so that people can more easily see when they're spoken to.
225		- const accum2 = f.replaceAtName.accum = [];
226		- //console.debug("f.accum =",f.accum);
227		- f.accum.forEach(function(v){
228		- //console.debug("v =",v);
229		- if('string'===typeof v){
230		- f.rxAt.lastIndex = f.replaceAtName.prevStart = 0;
231		- v.replace(f.rxAt, f.replaceAtName);
232		- if(f.replaceAtName.prevStart < v.length){
233		- accum2.push((f.replaceAtName.prevStart?' ':'')+v.substring(f.replaceAtName.prevStart));
234		- }
235		- }else{
236		- accum2.push(v);
237		- }
238		- //console.debug("accum2 =",accum2);
239		- });
240		- delete f.accum;
241		- //console.debug("accum2 =",accum2);
242		- const span = tgtElem \|\| f.ce('span');
243		- accum2.forEach(function(e){
244		- if('string'===typeof e) e = f.ct(e);
245		- span.appendChild(e);
246		- });
247		- //console.debug("span =",span.innerHTML);
248		- return span;
249		- }/end messageToDOM()/;
250		- /* Injects element e as a new row in the chat, at the top of the list */
251		- const injectMessage = function f(e){
252		- if(!f.injectPoint){
253		- f.injectPoint = document.querySelector('#message-inject-point');
254		- }
255		- if(f.injectPoint.nextSibling){
256		- f.injectPoint.parentNode.insertBefore(e, f.injectPoint.nextSibling);
257		- }else{
258		- f.injectPoint.parentNode.appendChild(e);
259		- }
260		- };
261		- /** Returns the local time string of Date object d, defaulting
262		- to the current time. */
263		- const localTimeString = function ff(d){
264		- if(!ff.pad){
265		- ff.pad = (x)=>(''+x).length>1 ? x : '0'+x;
266		- }
267		- d \|\| (d = new Date());
268		- return [
269		- d.getFullYear(),'-',ff.pad(d.getMonth()+1/sigh/),
270		- '-',ff.pad(d.getDate()),
271		- ' ',ff.pad(d.getHours()),':',ff.pad(d.getMinutes()),
272		- ':',ff.pad(d.getSeconds())
273		- ].join('');
274		- };
275		- function newcontent(jx){
276		- var i;
277		- for(i=0; i<jx.msgs.length; ++i){
278		- let m = jx.msgs[i];
279		- let row = document.createElement("fieldset");
280		- if( m.msgid>mxMsg ) mxMsg = m.msgid;
281		- row.classList.add('message-row');
282		- injectMessage(row);
283		- const eWho = document.createElement('legend');
284		- eWho.setAttribute('align', (m.xfrom===_me ? 'right' : 'left'));
285		- row.appendChild(eWho);
286		- eWho.classList.add('message-user');
287		- let whoName;
288		- if( m.xfrom===_me ){
289		- whoName = 'me';
290		- row.classList.add('user-is-me');
291		- }else{
292		- whoName = m.xfrom;
293		- }
294		- eWho.append(textNode(
295		- whoName+' @ '+
296		- localTimeString(new Date(Date.parse(m.mtime+".000Z"))))
297		- );
298		- let span = document.createElement("div");
299		- span.classList.add('message-content');
300		- row.appendChild(span);
301		- if( m.fsize>0 ){
302		- if( m.fmime && m.fmime.startsWith("image/") ){
303		- let img = document.createElement("img");
304		- img.src = "%string($downloadurl)/" + m.msgid;
305		- span.appendChild(img);
306		- }else{
307		- let a = document.createElement("a");
308		- let txt = "(" + m.fname + " " + m.fsize + " bytes)";
309		- a.href = "%string($downloadurl)/" + m.msgid;
310		- a.appendChild(document.createTextNode(txt));
311		- span.appendChild(a);
312		- }
313		- let br = document.createElement("br");
314		- br.style.clear = "both";
315		- span.appendChild(br);
316		- }
317		- if(m.xmsg){
318		- messageToDOM(m.xmsg, span);
319		- }
320		- span.classList.add('chat-message');
321		- if( m.xfrom!=_me ){
322		- span.classList.add('chat-mx');
323		- }else{
324		- span.classList.add('chat-ms');
325		- }
326		- }
327		- }
328		- async function poll(){
329		- if(poll.running) return;
330		- poll.running = true;
331		- fetch("%string($pollurl)/" + mxMsg)
332		- .then(x=>x.json())
333		- .then(y=>newcontent(y))
334		- .finally(()=>poll.running=false)
335		- }
336		- setInterval(poll, 1000);
337		-})();</script>
338		- }
339		-
340		- # Make sure the chat database exists
341		- sqlite3 db [chat-db-name]
342		- if {[db one {PRAGMA journal_mode}]!="wal"} {
343		- db eval {PRAGMA journal_mode=WAL}
344		- }
345		- db eval {
346		- CREATE TABLE IF NOT EXISTS chat(
347		- msgid INTEGER PRIMARY KEY AUTOINCREMENT,
348		- mtime JULIANDAY,
349		- xfrom TEXT,
350		- xto TEXT,
351		- xmsg TEXT,
352		- file BLOB,
353		- fname TEXT,
354		- fmime TEXT
355		- );
356		- CREATE TABLE IF NOT EXISTS ustat(
357		- uname TEXT PRIMARY KEY,
358		- mtime JULIANDAY, -- Last interaction
359		- seen INT, -- Last message seen
360		- logout JULIANDAY
361		- ) WITHOUT ROWID;
362		- }
363		- db close
364		-}
365		-
366		-# Show the CGI environment. Used for testing only.
367		-#
368		-proc wapp-page-env {} {
369		- wapp-trim {
370		- <div class="fossil-doc" data-title="Chat CGI Environment">
371		- <pre>%html([wapp-debug-env])</pre>
372		- </div>
373		- }
374		-}
375		-
376		-# Log the CGI environment into the "-logfile.txt" file in the same
377		-# directory as the script. Used for testing and development only.
378		-#
379		-proc logenv {} {
380		- set fn [file dir [wapp-param SCRIPT_FILENAME]]/-logfile.txt
381		- set out [open $fn a]
382		- puts $out {************************************************************}
383		- puts $out [wapp-debug-env]
384		- close $out
385		-}
386		-
387		-# A no-op page. Used for testing and development only.
388		-#
389		-proc noop-page {} {
390		- wapp-trim {
391		- <div class="fossil-doc" data-title="No-op"><h1>No-Op</h1></div>
392		- }
393		-}
394		-
395		-# Accept a new post via XHR.
396		-# No reply expected.
397		-#
398		-proc wapp-page-send {} {
399		- if {[not-authorized]} return
400		- set user [wapp-param FOSSIL_USER]
401		- set fcontent [wapp-param file.content]
402		- set fname [wapp-param file.filename]
403		- set fmime [wapp-param file.mimetype]
404		- set msg [wapp-param msg]
405		- sqlite3 db [chat-db-name]
406		- db eval BEGIN
407		- if {$fcontent!=""} {
408		- db eval {
409		- INSERT INTO chat(mtime,xfrom,xmsg,file,fname,fmime)
410		- VALUES(julianday('now'),$user,@msg,@fcontent,$fname,$fmime)
411		- }
412		- } else {
413		- db eval {
414		- INSERT INTO chat(mtime,xfrom,xmsg)
415		- VALUES(julianday('now'),$user,@msg)
416		- }
417		- }
418		- db eval {
419		- INSERT INTO ustat(uname,mtime,seen) VALUES($user,julianday('now'),0)
420		- ON CONFLICT(uname) DO UPDATE set mtime=julianday('now')
421		- }
422		- db eval COMMIT
423		- db close
424		-}
425		-
426		-# Request updates.
427		-# Delay the response until something changes (as this system works
428		-# using the Hanging-GET or Long-Poll style of server-push).
429		-# The result is javascript describing the new content.
430		-#
431		-# Call is like this: /poll/N
432		-# Where N is the last message received so far. The reply stalls
433		-# until newer messages are available.
434		-#
435		-proc wapp-page-poll {} {
436		- if {[not-authorized]} return
437		- wapp-mimetype text/json
438		- set msglist {}
439		- sqlite3 db [chat-db-name]
440		- set id 0
441		- scan [wapp-param PATH_TAIL] %d id
442		- while {1} {
443		- set datavers [db one {PRAGMA data_version}]
444		- db eval {SELECT msgid, datetime(mtime) AS dx, xfrom, CAST(xmsg AS text) mx,
445		- length(file) AS lx, fname, fmime
446		- FROM chat
447		- WHERE msgid>$id
448		- ORDER BY msgid} {
449		- set quname [string map {\" \\\"} $xfrom]
450		- set qmsg [string map {\" \\\"} $mx]
451		- if {$lx==""} {set lx 0}
452		- set qfname [string map {\" \\\"} $fname]
453		- lappend msglist "\173\"msgid\":$msgid,\"mtime\":\"$dx\",\
454		- \"xfrom\":\"$quname\",\
455		- \"xmsg\":\"$qmsg\",\"fsize\":$lx,\
456		- \"fname\":\"$qfname\",\"fmime\":\"$fmime\"\175"
457		- }
458		- if {[llength $msglist]>0} {
459		- wapp-unsafe "\173\042msgs\042:\133[join $msglist ,]\135\175"
460		- db close
461		- return
462		- }
463		- after 2000
464		- while {[db one {PRAGMA data_version}]==$datavers} {after 2000}
465		- }
466		-}
467		-
468		-# Show the text of this script.
469		-#
470		-proc wapp-page-self {} {
471		- wapp-trim {
472		- <div class="fossil-doc" data-title="Wapp Script for Chat">
473		- }
474		- set fd [open [wapp-param SCRIPT_FILENAME] rb]
475		- set script [read $fd]
476		- wapp-trim {
477		- <pre>%html($script)</pre>
478		- }
479		- wapp-trim {
480		- </div>
481		- }
482		-}
483		-
484		-# Download the file associated with a message.
485		-#
486		-# Call like this: /download/N
487		-# Where N is the message id.
488		-#
489		-proc wapp-page-download {} {
490		- if {[not-authorized]} {
491		- wapp-trim {
492		- <h1>Not authorized</h1>
493		- <p>You must have privileges to use this chatroom</p>
494		- </div>
495		- }
496		- return
497		- }
498		- set id 0
499		- scan [wapp-param PATH_TAIL] %d id
500		- sqlite3 db [chat-db-name]
501		- db eval {SELECT fname, fmime, file FROM chat WHERE msgid=$id} {
502		- wapp-mimetype $fmime
503		- wapp $file
504		- }
505		- db close
506		-}
507		-
508		-
509		-wapp-start $argv

	--- a/tools/chat.tcl
	+++ b/tools/chat.tcl
	@@ -1,509 +0,0 @@
1	#!/usr/bin/wapptclsh
2	#
3	# A chat program designed to run using the extcgi mechanism of Fossil.
4	#
5	encoding system utf-8
6
7	# The name of the chat database file
8	#
9	proc chat-db-name {} {
10	set x [wapp-param SCRIPT_FILENAME]
11	set dir [file dir $x]
12	set fn [file tail $x]
13	return $dir/-$fn.db
14	}
15
16	# Verify permission to use chat. Return true if not authorized.
17	# Return false if the Fossil user is allowed to access chat.
18	#
19	proc not-authorized {} {
20	set cap [wapp-param FOSSIL_CAPABILITIES]
21	return [expr {![string match i $cap]}]
22	}
23
24	# The default page.
25	# Load the initial chat screen.
26	#
27	proc wapp-default {} {
28	wapp-content-security-policy off
29	wapp-trim {
30	<div class="fossil-doc" data-title="Chat">
31	}
32	if {[not-authorized]} {
33	wapp-trim {
34	<h1>Not authorized</h1>
35	<p>You must have privileges to use this chatroom</p>
36	</div>
37	}
38	return
39	}
40	set scriptFile [wapp-param SCRIPT_FILENAME]
41	set cgiFn [file tail $scriptFile]
42	wapp-trim {
43	<form accept-encoding="utf-8" id="chat-form">
44	<div id='chat-input-area'>
45	<div id='chat-input-line'>
46	<input type="text" name="msg" id="sbox" placeholder="Type message here.">
47	<input type="submit" value="Send">
48	</div>
49	<div id='chat-input-file'>
50	<span>File:</span>
51	<input type="file" name="file">
52	</div>
53	</div>
54	</form>
55	<hr>
56	<span id='message-inject-point'><!--
57	new chat messages get inserted immediately after this element
58	--></span>
59
60	</div><!-- .fossil-doc -->
61	<hr>
62	<p>
63	<a href="%string($cgiFn)/env">CGI environment</a> \|
64	<a href="%string($cgiFn)/self">Wapp script</a>
65	<style>
66	\#dialog {
67	width: 97%;
68	}
69	\#chat-input-area {
70	width: 100%;
71	display: flex;
72	flex-direction: column;
73	}
74	\#chat-input-line {
75	display: flex;
76	flex-direction: row;
77	margin-bottom: 1em;
78	align-items: center;
79	}
80	\#chat-input-line > input[type=submit] {
81	flex: 1 5 auto;
82	max-width: 6em;
83	}
84	\#chat-input-line > input[type=text] {
85	flex: 5 1 auto;
86	}
87	\#chat-input-file {
88	display: flex;
89	flex-direction: row;
90	align-items: center;
91	}
92	\#chat-input-file > input {
93	flex: 1 0 auto;
94	}
95	span.at-name { /* for @USERNAME references */
96	text-decoration: underline;
97	font-weight: bold;
98	}
99	/* A wrapper for a single single message (one row of the UI) */
100	.message-row {
101	margin-bottom: 0.5em;
102	border: none;
103	display: flex;
104	flex-direction: row;
105	justify-content: flex-start;
106	/*border: 1px solid rgba(0,0,0,0.2);
107	border-radius: 0.25em;
108	box-shadow: 0.2em 0.2em 0.2em rgba(0, 0, 0, 0.29);*/
109	border: none;
110	}
111	/* Rows for the current user have the .user-is-me CSS class
112	and get right-aligned. */
113	.message-row.user-is-me {
114	justify-content: flex-end;
115	/background-color: #d2dde1;/
116	}
117	/* The content area of a message (the body element of a FIELDSET) */
118	.message-content {
119	display: inline-block;
120	border-radius: 0.25em;
121	border: 1px solid rgba(0,0,0,0.2);
122	box-shadow: 0.2em 0.2em 0.2em rgba(0, 0, 0, 0.29);
123	padding: 0.25em 1em;
124	margin-top: -0.75em;
125	}
126	.message-row.user-is-me .message-content {
127	background-color: #d2dde1;
128	}
129	/* User name for the post (a LEGEND element) */
130	.message-row .message-user {
131	background: inherit;
132	border-radius: 0.25em 0.25em 0 0;
133	padding: 0 0.5em;
134	/text-align: left; Firefox requires the 'align' attribute /
135	margin-left: 0.25em;
136	padding: 0 0.5em 0em 0.5em;
137	margin-bottom: 0.4em;
138	background-color: #d2dde1;
139	}
140	/* Reposition "my" posts to the right */
141	.message-row.user-is-me .message-user {
142	/text-align: right; Firefox requires the 'align' attribute /
143	margin-left: 0;
144	margin-right: 0.25em;
145	}
146	</style>
147	}
148	set nonce [wapp-param FOSSIL_NONCE]
149	set submiturl [wapp-param SCRIPT_NAME]/send
150	set pollurl [wapp-param SCRIPT_NAME]/poll
151	set downloadurl [wapp-param SCRIPT_NAME]/download
152	set me [wapp-param FOSSIL_USER]
153	wapp-trim {
154	<script nonce="%string($nonce)">
155	(function(){
156	const form = document.querySelector('#chat-form');
157	let mxMsg = 0;
158	let _me = "%string($me)";
159	form.addEventListener('submit',(e)=>{
160	e.preventDefault();
161	if( form.msg.value.length>0 \|\| form.file.value.length>0 ){
162	fetch("%string($submiturl)",{
163	method: 'POST',
164	body: new FormData(form)
165	});
166	}
167	form.msg.value = "";
168	form.file.value = "";
169	form.msg.focus();
170	});
171	const rxUrl = /\\b(?:https?\|ftp):\\/\\/\[a-z0-9-+&@\#\\/%?=~_\|!:,.;]*\[a-z0-9-+&@\#\\/%=~_\|]/gim;
172	const rxAtName = /@\\w+/gmi;
173	// ^^^ achtung, extra backslashes needed for the outer TCL.
174	const textNode = (T)=>document.createTextNode(T);
175
176	// Converts a message string to a message-containing DOM element
177	// and returns that element, which may contain child elements.
178	// If 2nd arg is passed, it must be a DOM element to which all
179	// child elements are appended.
180	const messageToDOM = function f(str, tgtElem){
181	"use strict";
182	if(!f.rxUrl){
183	f.rxUrl = rxUrl;
184	f.rxAt = rxAtName;
185	f.rxNS = /\\S/;
186	f.ce = (T)=>document.createElement(T);
187	f.ct = (T)=>document.createTextNode(T);
188	f.replaceUrls = function ff(sub, offset, whole){
189	if(offset > ff.prevStart){
190	f.accum.push((ff.prevStart?' ':'')+whole.substring(ff.prevStart, offset-1)+' ');
191	}
192	const a = f.ce('a');
193	a.setAttribute('href',sub);
194	a.setAttribute('target','_blank');
195	a.appendChild(f.ct(sub));
196	f.accum.push(a);
197	ff.prevStart = offset + sub.length + 1;
198	};
199	f.replaceAtName = function ff(sub, offset,whole){
200	if(offset > ff.prevStart){
201	ff.accum.push((ff.prevStart?' ':'')+whole.substring(ff.prevStart, offset-1)+' ');
202	}else if(offset && f.rxNS.test(whole[offset-1])){
203	// Sigh: https://stackoverflow.com/questions/52655367
204	ff.accum.push(sub);
205	return;
206	}
207	const e = f.ce('span');
208	e.classList.add('at-name');
209	e.appendChild(f.ct(sub));
210	ff.accum.push(e);
211	ff.prevStart = offset + sub.length + 1;
212	};
213	}
214	f.accum = []; // accumulate strings and DOM elements here.
215	f.rxUrl.lastIndex = f.replaceUrls.prevStart = 0; // reset regex cursor
216	str.replace(f.rxUrl, f.replaceUrls);
217	// Push remaining non-URL part of the string to the queue...
218	if(f.replaceUrls.prevStart < str.length){
219	f.accum.push((f.replaceUrls.prevStart?' ':'')+str.substring(f.replaceUrls.prevStart));
220	}
221	// Pass 2: process @NAME references...
222	// TODO: only match NAME if it's the name of a currently participating
223	// user. Add a second class if NAME == current user, and style that one
224	// differently so that people can more easily see when they're spoken to.
225	const accum2 = f.replaceAtName.accum = [];
226	//console.debug("f.accum =",f.accum);
227	f.accum.forEach(function(v){
228	//console.debug("v =",v);
229	if('string'===typeof v){
230	f.rxAt.lastIndex = f.replaceAtName.prevStart = 0;
231	v.replace(f.rxAt, f.replaceAtName);
232	if(f.replaceAtName.prevStart < v.length){
233	accum2.push((f.replaceAtName.prevStart?' ':'')+v.substring(f.replaceAtName.prevStart));
234	}
235	}else{
236	accum2.push(v);
237	}
238	//console.debug("accum2 =",accum2);
239	});
240	delete f.accum;
241	//console.debug("accum2 =",accum2);
242	const span = tgtElem \|\| f.ce('span');
243	accum2.forEach(function(e){
244	if('string'===typeof e) e = f.ct(e);
245	span.appendChild(e);
246	});
247	//console.debug("span =",span.innerHTML);
248	return span;
249	}/end messageToDOM()/;
250	/* Injects element e as a new row in the chat, at the top of the list */
251	const injectMessage = function f(e){
252	if(!f.injectPoint){
253	f.injectPoint = document.querySelector('#message-inject-point');
254	}
255	if(f.injectPoint.nextSibling){
256	f.injectPoint.parentNode.insertBefore(e, f.injectPoint.nextSibling);
257	}else{
258	f.injectPoint.parentNode.appendChild(e);
259	}
260	};
261	/** Returns the local time string of Date object d, defaulting
262	to the current time. */
263	const localTimeString = function ff(d){
264	if(!ff.pad){
265	ff.pad = (x)=>(''+x).length>1 ? x : '0'+x;
266	}
267	d \|\| (d = new Date());
268	return [
269	d.getFullYear(),'-',ff.pad(d.getMonth()+1/sigh/),
270	'-',ff.pad(d.getDate()),
271	' ',ff.pad(d.getHours()),':',ff.pad(d.getMinutes()),
272	':',ff.pad(d.getSeconds())
273	].join('');
274	};
275	function newcontent(jx){
276	var i;
277	for(i=0; i<jx.msgs.length; ++i){
278	let m = jx.msgs[i];
279	let row = document.createElement("fieldset");
280	if( m.msgid>mxMsg ) mxMsg = m.msgid;
281	row.classList.add('message-row');
282	injectMessage(row);
283	const eWho = document.createElement('legend');
284	eWho.setAttribute('align', (m.xfrom===_me ? 'right' : 'left'));
285	row.appendChild(eWho);
286	eWho.classList.add('message-user');
287	let whoName;
288	if( m.xfrom===_me ){
289	whoName = 'me';
290	row.classList.add('user-is-me');
291	}else{
292	whoName = m.xfrom;
293	}
294	eWho.append(textNode(
295	whoName+' @ '+
296	localTimeString(new Date(Date.parse(m.mtime+".000Z"))))
297	);
298	let span = document.createElement("div");
299	span.classList.add('message-content');
300	row.appendChild(span);
301	if( m.fsize>0 ){
302	if( m.fmime && m.fmime.startsWith("image/") ){
303	let img = document.createElement("img");
304	img.src = "%string($downloadurl)/" + m.msgid;
305	span.appendChild(img);
306	}else{
307	let a = document.createElement("a");
308	let txt = "(" + m.fname + " " + m.fsize + " bytes)";
309	a.href = "%string($downloadurl)/" + m.msgid;
310	a.appendChild(document.createTextNode(txt));
311	span.appendChild(a);
312	}
313	let br = document.createElement("br");
314	br.style.clear = "both";
315	span.appendChild(br);
316	}
317	if(m.xmsg){
318	messageToDOM(m.xmsg, span);
319	}
320	span.classList.add('chat-message');
321	if( m.xfrom!=_me ){
322	span.classList.add('chat-mx');
323	}else{
324	span.classList.add('chat-ms');
325	}
326	}
327	}
328	async function poll(){
329	if(poll.running) return;
330	poll.running = true;
331	fetch("%string($pollurl)/" + mxMsg)
332	.then(x=>x.json())
333	.then(y=>newcontent(y))
334	.finally(()=>poll.running=false)
335	}
336	setInterval(poll, 1000);
337	})();</script>
338	}
339
340	# Make sure the chat database exists
341	sqlite3 db [chat-db-name]
342	if {[db one {PRAGMA journal_mode}]!="wal"} {
343	db eval {PRAGMA journal_mode=WAL}
344	}
345	db eval {
346	CREATE TABLE IF NOT EXISTS chat(
347	msgid INTEGER PRIMARY KEY AUTOINCREMENT,
348	mtime JULIANDAY,
349	xfrom TEXT,
350	xto TEXT,
351	xmsg TEXT,
352	file BLOB,
353	fname TEXT,
354	fmime TEXT
355	);
356	CREATE TABLE IF NOT EXISTS ustat(
357	uname TEXT PRIMARY KEY,
358	mtime JULIANDAY, -- Last interaction
359	seen INT, -- Last message seen
360	logout JULIANDAY
361	) WITHOUT ROWID;
362	}
363	db close
364	}
365
366	# Show the CGI environment. Used for testing only.
367	#
368	proc wapp-page-env {} {
369	wapp-trim {
370	<div class="fossil-doc" data-title="Chat CGI Environment">
371	<pre>%html([wapp-debug-env])</pre>
372	</div>
373	}
374	}
375
376	# Log the CGI environment into the "-logfile.txt" file in the same
377	# directory as the script. Used for testing and development only.
378	#
379	proc logenv {} {
380	set fn [file dir [wapp-param SCRIPT_FILENAME]]/-logfile.txt
381	set out [open $fn a]
382	puts $out {************************************************************}
383	puts $out [wapp-debug-env]
384	close $out
385	}
386
387	# A no-op page. Used for testing and development only.
388	#
389	proc noop-page {} {
390	wapp-trim {
391	<div class="fossil-doc" data-title="No-op"><h1>No-Op</h1></div>
392	}
393	}
394
395	# Accept a new post via XHR.
396	# No reply expected.
397	#
398	proc wapp-page-send {} {
399	if {[not-authorized]} return
400	set user [wapp-param FOSSIL_USER]
401	set fcontent [wapp-param file.content]
402	set fname [wapp-param file.filename]
403	set fmime [wapp-param file.mimetype]
404	set msg [wapp-param msg]
405	sqlite3 db [chat-db-name]
406	db eval BEGIN
407	if {$fcontent!=""} {
408	db eval {
409	INSERT INTO chat(mtime,xfrom,xmsg,file,fname,fmime)
410	VALUES(julianday('now'),$user,@msg,@fcontent,$fname,$fmime)
411	}
412	} else {
413	db eval {
414	INSERT INTO chat(mtime,xfrom,xmsg)
415	VALUES(julianday('now'),$user,@msg)
416	}
417	}
418	db eval {
419	INSERT INTO ustat(uname,mtime,seen) VALUES($user,julianday('now'),0)
420	ON CONFLICT(uname) DO UPDATE set mtime=julianday('now')
421	}
422	db eval COMMIT
423	db close
424	}
425
426	# Request updates.
427	# Delay the response until something changes (as this system works
428	# using the Hanging-GET or Long-Poll style of server-push).
429	# The result is javascript describing the new content.
430	#
431	# Call is like this: /poll/N
432	# Where N is the last message received so far. The reply stalls
433	# until newer messages are available.
434	#
435	proc wapp-page-poll {} {
436	if {[not-authorized]} return
437	wapp-mimetype text/json
438	set msglist {}
439	sqlite3 db [chat-db-name]
440	set id 0
441	scan [wapp-param PATH_TAIL] %d id
442	while {1} {
443	set datavers [db one {PRAGMA data_version}]
444	db eval {SELECT msgid, datetime(mtime) AS dx, xfrom, CAST(xmsg AS text) mx,
445	length(file) AS lx, fname, fmime
446	FROM chat
447	WHERE msgid>$id
448	ORDER BY msgid} {
449	set quname [string map {\" \\\"} $xfrom]
450	set qmsg [string map {\" \\\"} $mx]
451	if {$lx==""} {set lx 0}
452	set qfname [string map {\" \\\"} $fname]
453	lappend msglist "\173\"msgid\":$msgid,\"mtime\":\"$dx\",\
454	\"xfrom\":\"$quname\",\
455	\"xmsg\":\"$qmsg\",\"fsize\":$lx,\
456	\"fname\":\"$qfname\",\"fmime\":\"$fmime\"\175"
457	}
458	if {[llength $msglist]>0} {
459	wapp-unsafe "\173\042msgs\042:\133[join $msglist ,]\135\175"
460	db close
461	return
462	}
463	after 2000
464	while {[db one {PRAGMA data_version}]==$datavers} {after 2000}
465	}
466	}
467
468	# Show the text of this script.
469	#
470	proc wapp-page-self {} {
471	wapp-trim {
472	<div class="fossil-doc" data-title="Wapp Script for Chat">
473	}
474	set fd [open [wapp-param SCRIPT_FILENAME] rb]
475	set script [read $fd]
476	wapp-trim {
477	<pre>%html($script)</pre>
478	}
479	wapp-trim {
480	</div>
481	}
482	}
483
484	# Download the file associated with a message.
485	#
486	# Call like this: /download/N
487	# Where N is the message id.
488	#
489	proc wapp-page-download {} {
490	if {[not-authorized]} {
491	wapp-trim {
492	<h1>Not authorized</h1>
493	<p>You must have privileges to use this chatroom</p>
494	</div>
495	}
496	return
497	}
498	set id 0
499	scan [wapp-param PATH_TAIL] %d id
500	sqlite3 db [chat-db-name]
501	db eval {SELECT fname, fmime, file FROM chat WHERE msgid=$id} {
502	wapp-mimetype $fmime
503	wapp $file
504	}
505	db close
506	}
507
508
509	wapp-start $argv

	--- a/tools/chat.tcl
	+++ b/tools/chat.tcl
	@@ -1,509 +0,0 @@

D tools/fossil_chat.tcl

-257

		--- a/tools/fossil_chat.tcl
		+++ b/tools/fossil_chat.tcl
		@@ -1,257 +0,0 @@
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		-# set to correct values if you have to use a proxy
13		-set PROXYHOST {}
14		-set PROXYPORT {}
15		-
16		-# Setup the user interface
17		-wm title . Fossil-Chat
18		-wm iconname . [wm title .]
19		-
20		-menu .mb -type menubar
21		-if {$tcl_platform(platform)=="unix" && $tcl_platform(os)!="Darwin"} {
22		- pack .mb -side top -fill x
23		-} else {
24		- . config -menu .mb
25		-}
26		-.mb add cascade -label File -underline 0 -menu .mb.file
27		-menu .mb.file -tearoff 0
28		-.mb.file add command -label Send -command send_message
29		-.mb.file add command -label {Remove older messages} -command cleanup_record
30		-.mb.file add separator
31		-.mb.file add command -label {Exit} -command exit
32		-
33		-frame .who
34		-pack .who -side right -anchor n -fill y
35		-label .who.title -text {Users: }
36		-pack .who.title -side top -anchor nw
37		-label .who.list -anchor w -justify left -text {}
38		-pack .who.list -side top -anchor nw -expand 1 -padx 5
39		-label .who.time -text {} -justify right
40		-proc update_time {} {
41		- after 1000 update_time
42		- set now [clock seconds]
43		- set time [clock format $now -format %H:%M -gmt 1]
44		- .who.time config -text "UTC: $time"
45		-}
46		-update_time
47		-pack .who.time -side bottom -anchor sw
48		-
49		-frame .input
50		-pack .input -side bottom -fill x
51		-text .input.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 3 \
52		- -wrap word -yscrollcommand [list .input.sb set] -takefocus 1
53		-bind .input.t <Key-Return> {send_message; break}
54		-pack .input.t -side left -fill both -expand 1
55		-scrollbar .input.sb -orient vertical -command [list .input.t yview]
56		-pack .input.sb -side left -fill y
57		-
58		-frame .msg
59		-pack .msg -side top -fill both -expand 1
60		-text .msg.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 20 \
61		- -wrap word -yscrollcommand [list .msg.sb set] -takefocus 0
62		-bindtags .msg.t [list .msg.t . all]
63		-.msg.t tag config error -foreground red
64		-.msg.t tag config meta -foreground forestgreen
65		-.msg.t tag config norm -foreground black
66		-pack .msg.t -side left -fill both -expand 1
67		-scrollbar .msg.sb -orient vertical -command [list .msg.t yview]
68		-pack .msg.sb -side left -fill y
69		-
70		-update
71		-
72		-# Send periodic messages to keep the TCP/IP link up
73		-#
74		-proc keep_alive {} {
75		- global TIMER SOCKET
76		- catch {after cancel $TIMER}
77		- set TIMER [after 300000 keep_alive]
78		- catch {puts $SOCKET noop; flush $SOCKET}
79		-}
80		-
81		-# Connect to the server
82		-proc connect {} {
83		- global SOCKET tcl_platform
84		- catch {close $SOCKET}
85		- if {[catch {
86		- if {$::PROXYHOST ne {}} {
87		- set SOCKET [socket $::PROXYHOST $::PROXYPORT]
88		- puts $SOCKET "CONNECT $::SERVERHOST:$::SERVERPORT HTTP/1.1"
89		- puts $SOCKET "Host: $::SERVERHOST:$::SERVERPORT"
90		- puts $SOCKET ""
91		- } else {
92		- set SOCKET [socket $::SERVERHOST $::SERVERPORT]
93		- }
94		- fconfigure $SOCKET -translation binary -blocking 0
95		- puts $SOCKET [list login $tcl_platform(user) fact,fuzz]
96		- flush $SOCKET
97		- fileevent $SOCKET readable handle_input
98		- keep_alive
99		- } errmsg]} {
100		- if {[tk_messageBox -icon error -type yesno -parent . -message \
101		- "Unable to connect to server. $errmsg.\n\nTry again?"]=="yes"} {
102		- after 100 connect
103		- }
104		- }
105		-}
106		-connect
107		-
108		-# Send the message text contained in the .input.t widget to the server.
109		-#
110		-proc send_message {} {
111		- set txt [.input.t get 1.0 end]
112		- .input.t delete 1.0 end
113		- regsub -all "\[ \t\n\f\r\]+" [string trim $txt] { } txt
114		- if {$txt==""} return
115		- global SOCKET
116		- puts $SOCKET [list message $txt]
117		- flush $SOCKET
118		-}
119		-
120		-.mb add cascade -label "Transfer" -underline 0 -menu .mb.files
121		-menu .mb.files -tearoff 0
122		-.mb.files add command -label "Send file..." -command send_file
123		-.mb.files add command -label "Delete files" -command delete_files \
124		- -state disabled
125		-.mb.files add separator
126		-
127		-# Encode a string (possibly containing binary and \000 characters) into
128		-# single line of text.
129		-#
130		-proc encode {txt} {
131		- return [string map [list % %25 + %2b " " + \n %0a \t %09 \000 %00] $txt]
132		-}
133		-
134		-# Undo the work of encode. Convert an encoded string back into its original
135		-# form.
136		-#
137		-proc decode {txt} {
138		- return [string map [list %00 \000 %09 \t %0a \n + " " %2b + %25 %] $txt]
139		-}
140		-
141		-# Delete all of the downloaded files we are currently holding.
142		-#
143		-proc delete_files {} {
144		- global FILES
145		- .mb.files delete 3 end
146		- array unset FILES
147		- .mb.files entryconfigure 1 -state disabled
148		-}
149		-
150		-# Prompt the user to select a file from the disk. Then send that
151		-# file to all chat participants.
152		-#
153		-proc send_file {} {
154		- global SOCKET
155		- set openfile [tk_getOpenFile]
156		- if {$openfile==""} return
157		- set f [open $openfile]
158		- fconfigure $f -translation binary
159		- set data [read $f]
160		- close $f
161		- puts $SOCKET [list file [file tail $openfile] [encode $data]]
162		- flush $SOCKET
163		- set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
164		- .msg.t insert end "\[$time\] sent file [file tail $openfile]\
165		- - [string length $data] bytes\n" meta
166		- .msg.t see end
167		-}
168		-
169		-# Save the named file to the disk.
170		-#
171		- proc save_file {filename} {
172		- global FILES
173		- set savefile [tk_getSaveFile -initialfile $filename]
174		- if {$savefile==""} return
175		- set f [open $savefile w]
176		- fconfigure $f -translation binary
177		- puts -nonewline $f [decode $FILES($filename)]
178		- close $f
179		-}
180		-
181		-# Handle a "file" message from the chat server.
182		-#
183		-proc handle_file {from filename data} {
184		- global FILES
185		- foreach prior [array names FILES] {
186		- if {$filename==$prior} break
187		- }
188		- if {![info exists prior] \|\| $filename!=$prior} {
189		- .mb.files add command -label "Save \"$filename\"" \
190		- -command [list save_file $filename]
191		- }
192		- set FILES($filename) $data
193		- .mb.files entryconfigure 1 -state active
194		- set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
195		- .msg.t insert end "\[$time $from\] " meta "File: \"$filename\"\n" norm
196		- .msg.t see end
197		-}
198		-
199		-# Handle input from the server
200		-#
201		-proc handle_input {} {
202		- global SOCKET
203		- if {[eof $SOCKET]} {
204		- disconnect
205		- return
206		- }
207		- set line [gets $SOCKET]
208		- if {$line==""} return
209		- set cmd [lindex $line 0]
210		- if {$cmd=="userlist"} {
211		- set ulist {}
212		- foreach u [lrange $line 1 end] {
213		- append ulist $u\n
214		- }
215		- .who.list config -text [string trim $ulist]
216		- } elseif {$cmd=="message"} {
217		- set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
218		- set from [lindex $line 1]
219		- .msg.t insert end "\[$time $from\] " meta [lindex $line 2]\n norm
220		- .msg.t see end
221		- bell
222		- wm deiconify .
223		- update
224		- raise .
225		- } elseif {$cmd=="noop"} {
226		- # do nothing
227		- } elseif {$cmd=="meta"} {
228		- set now [clock seconds]
229		- set time [clock format $now -format {%H:%M} -gmt 1]
230		- .msg.t insert end "\[$time\] [lindex $line 1]\n" meta
231		- .msg.t see end
232		- } elseif {$cmd=="file"} {
233		- if {[info commands handle_file]=="handle_file"} {
234		- handle_file [lindex $line 1] [lindex $line 2] [lindex $line 3]
235		- }
236		- }
237		-}
238		-
239		-# Handle a broken socket connection
240		-#
241		-proc disconnect {} {
242		- global SOCKET
243		- close $SOCKET
244		- set q [tk_messageBox -icon error -type yesno -parent . -message \
245		- "TCP/IP link lost. Try to reconnet?"]
246		- if {$q=="yes"} {
247		- connect
248		- } else {
249		- exit
250		- }
251		-}
252		-
253		-# Remove all but the most recent 100 message from the message log
254		-#
255		-proc cleanup_record {} {
256		- .msg.t delete 1.0 {end -100 lines}
257		-}

	--- a/tools/fossil_chat.tcl
	+++ b/tools/fossil_chat.tcl
	@@ -1,257 +0,0 @@
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	# set to correct values if you have to use a proxy
13	set PROXYHOST {}
14	set PROXYPORT {}
15
16	# Setup the user interface
17	wm title . Fossil-Chat
18	wm iconname . [wm title .]
19
20	menu .mb -type menubar
21	if {$tcl_platform(platform)=="unix" && $tcl_platform(os)!="Darwin"} {
22	pack .mb -side top -fill x
23	} else {
24	. config -menu .mb
25	}
26	.mb add cascade -label File -underline 0 -menu .mb.file
27	menu .mb.file -tearoff 0
28	.mb.file add command -label Send -command send_message
29	.mb.file add command -label {Remove older messages} -command cleanup_record
30	.mb.file add separator
31	.mb.file add command -label {Exit} -command exit
32
33	frame .who
34	pack .who -side right -anchor n -fill y
35	label .who.title -text {Users: }
36	pack .who.title -side top -anchor nw
37	label .who.list -anchor w -justify left -text {}
38	pack .who.list -side top -anchor nw -expand 1 -padx 5
39	label .who.time -text {} -justify right
40	proc update_time {} {
41	after 1000 update_time
42	set now [clock seconds]
43	set time [clock format $now -format %H:%M -gmt 1]
44	.who.time config -text "UTC: $time"
45	}
46	update_time
47	pack .who.time -side bottom -anchor sw
48
49	frame .input
50	pack .input -side bottom -fill x
51	text .input.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 3 \
52	-wrap word -yscrollcommand [list .input.sb set] -takefocus 1
53	bind .input.t <Key-Return> {send_message; break}
54	pack .input.t -side left -fill both -expand 1
55	scrollbar .input.sb -orient vertical -command [list .input.t yview]
56	pack .input.sb -side left -fill y
57
58	frame .msg
59	pack .msg -side top -fill both -expand 1
60	text .msg.t -bd 1 -relief sunken -bg white -fg black -width 60 -height 20 \
61	-wrap word -yscrollcommand [list .msg.sb set] -takefocus 0
62	bindtags .msg.t [list .msg.t . all]
63	.msg.t tag config error -foreground red
64	.msg.t tag config meta -foreground forestgreen
65	.msg.t tag config norm -foreground black
66	pack .msg.t -side left -fill both -expand 1
67	scrollbar .msg.sb -orient vertical -command [list .msg.t yview]
68	pack .msg.sb -side left -fill y
69
70	update
71
72	# Send periodic messages to keep the TCP/IP link up
73	#
74	proc keep_alive {} {
75	global TIMER SOCKET
76	catch {after cancel $TIMER}
77	set TIMER [after 300000 keep_alive]
78	catch {puts $SOCKET noop; flush $SOCKET}
79	}
80
81	# Connect to the server
82	proc connect {} {
83	global SOCKET tcl_platform
84	catch {close $SOCKET}
85	if {[catch {
86	if {$::PROXYHOST ne {}} {
87	set SOCKET [socket $::PROXYHOST $::PROXYPORT]
88	puts $SOCKET "CONNECT $::SERVERHOST:$::SERVERPORT HTTP/1.1"
89	puts $SOCKET "Host: $::SERVERHOST:$::SERVERPORT"
90	puts $SOCKET ""
91	} else {
92	set SOCKET [socket $::SERVERHOST $::SERVERPORT]
93	}
94	fconfigure $SOCKET -translation binary -blocking 0
95	puts $SOCKET [list login $tcl_platform(user) fact,fuzz]
96	flush $SOCKET
97	fileevent $SOCKET readable handle_input
98	keep_alive
99	} errmsg]} {
100	if {[tk_messageBox -icon error -type yesno -parent . -message \
101	"Unable to connect to server. $errmsg.\n\nTry again?"]=="yes"} {
102	after 100 connect
103	}
104	}
105	}
106	connect
107
108	# Send the message text contained in the .input.t widget to the server.
109	#
110	proc send_message {} {
111	set txt [.input.t get 1.0 end]
112	.input.t delete 1.0 end
113	regsub -all "\[ \t\n\f\r\]+" [string trim $txt] { } txt
114	if {$txt==""} return
115	global SOCKET
116	puts $SOCKET [list message $txt]
117	flush $SOCKET
118	}
119
120	.mb add cascade -label "Transfer" -underline 0 -menu .mb.files
121	menu .mb.files -tearoff 0
122	.mb.files add command -label "Send file..." -command send_file
123	.mb.files add command -label "Delete files" -command delete_files \
124	-state disabled
125	.mb.files add separator
126
127	# Encode a string (possibly containing binary and \000 characters) into
128	# single line of text.
129	#
130	proc encode {txt} {
131	return [string map [list % %25 + %2b " " + \n %0a \t %09 \000 %00] $txt]
132	}
133
134	# Undo the work of encode. Convert an encoded string back into its original
135	# form.
136	#
137	proc decode {txt} {
138	return [string map [list %00 \000 %09 \t %0a \n + " " %2b + %25 %] $txt]
139	}
140
141	# Delete all of the downloaded files we are currently holding.
142	#
143	proc delete_files {} {
144	global FILES
145	.mb.files delete 3 end
146	array unset FILES
147	.mb.files entryconfigure 1 -state disabled
148	}
149
150	# Prompt the user to select a file from the disk. Then send that
151	# file to all chat participants.
152	#
153	proc send_file {} {
154	global SOCKET
155	set openfile [tk_getOpenFile]
156	if {$openfile==""} return
157	set f [open $openfile]
158	fconfigure $f -translation binary
159	set data [read $f]
160	close $f
161	puts $SOCKET [list file [file tail $openfile] [encode $data]]
162	flush $SOCKET
163	set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
164	.msg.t insert end "\[$time\] sent file [file tail $openfile]\
165	- [string length $data] bytes\n" meta
166	.msg.t see end
167	}
168
169	# Save the named file to the disk.
170	#
171	proc save_file {filename} {
172	global FILES
173	set savefile [tk_getSaveFile -initialfile $filename]
174	if {$savefile==""} return
175	set f [open $savefile w]
176	fconfigure $f -translation binary
177	puts -nonewline $f [decode $FILES($filename)]
178	close $f
179	}
180
181	# Handle a "file" message from the chat server.
182	#
183	proc handle_file {from filename data} {
184	global FILES
185	foreach prior [array names FILES] {
186	if {$filename==$prior} break
187	}
188	if {![info exists prior] \|\| $filename!=$prior} {
189	.mb.files add command -label "Save \"$filename\"" \
190	-command [list save_file $filename]
191	}
192	set FILES($filename) $data
193	.mb.files entryconfigure 1 -state active
194	set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
195	.msg.t insert end "\[$time $from\] " meta "File: \"$filename\"\n" norm
196	.msg.t see end
197	}
198
199	# Handle input from the server
200	#
201	proc handle_input {} {
202	global SOCKET
203	if {[eof $SOCKET]} {
204	disconnect
205	return
206	}
207	set line [gets $SOCKET]
208	if {$line==""} return
209	set cmd [lindex $line 0]
210	if {$cmd=="userlist"} {
211	set ulist {}
212	foreach u [lrange $line 1 end] {
213	append ulist $u\n
214	}
215	.who.list config -text [string trim $ulist]
216	} elseif {$cmd=="message"} {
217	set time [clock format [clock seconds] -format {%H:%M} -gmt 1]
218	set from [lindex $line 1]
219	.msg.t insert end "\[$time $from\] " meta [lindex $line 2]\n norm
220	.msg.t see end
221	bell
222	wm deiconify .
223	update
224	raise .
225	} elseif {$cmd=="noop"} {
226	# do nothing
227	} elseif {$cmd=="meta"} {
228	set now [clock seconds]
229	set time [clock format $now -format {%H:%M} -gmt 1]
230	.msg.t insert end "\[$time\] [lindex $line 1]\n" meta
231	.msg.t see end
232	} elseif {$cmd=="file"} {
233	if {[info commands handle_file]=="handle_file"} {
234	handle_file [lindex $line 1] [lindex $line 2] [lindex $line 3]
235	}
236	}
237	}
238
239	# Handle a broken socket connection
240	#
241	proc disconnect {} {
242	global SOCKET
243	close $SOCKET
244	set q [tk_messageBox -icon error -type yesno -parent . -message \
245	"TCP/IP link lost. Try to reconnet?"]
246	if {$q=="yes"} {
247	connect
248	} else {
249	exit
250	}
251	}
252
253	# Remove all but the most recent 100 message from the message log
254	#
255	proc cleanup_record {} {
256	.msg.t delete 1.0 {end -100 lines}
257	}

	--- a/tools/fossil_chat.tcl
	+++ b/tools/fossil_chat.tcl
	@@ -1,257 +0,0 @@

Fossil SCM

Keyboard Shortcuts