Artifact
0f1fb7352b76043abec0d50321edaac59e5fb3ba616c744e40e14417d3ff90ab:
0000: 23 21 2f 75 73 72 2f 62 69 6e 2f 65 6e 76 20 74 #!/usr/bin/env t
0010: 63 6c 73 68 0a 23 0a 23 20 45 78 61 6d 70 6c 65 clsh.#.# Example
0020: 20 65 6e 63 72 79 70 74 65 64 20 65 63 68 6f 20 encrypted echo
0030: 63 68 61 74 20 74 6f 6f 6c 0a 23 0a 23 20 55 73 chat tool.#.# Us
0040: 61 67 65 3a 0a 23 09 53 65 72 76 65 72 3a 09 09 age:.#.Server:..
0050: 74 63 6c 73 68 20 65 63 68 61 74 2e 74 63 6c 20 tclsh echat.tcl
0060: 2d 73 65 72 76 65 72 0a 23 0a 23 09 43 6c 69 65 -server.#.#.Clie
0070: 6e 74 3a 09 09 74 63 6c 73 68 20 65 63 68 61 74 nt:..tclsh echat
0080: 2e 74 63 6c 20 2d 63 6c 69 65 6e 74 0a 23 0a 0a .tcl -client.#..
0090: 70 61 63 6b 61 67 65 20 70 72 65 66 65 72 20 6c package prefer l
00a0: 61 74 65 73 74 0a 70 61 63 6b 61 67 65 20 72 65 atest.package re
00b0: 71 75 69 72 65 20 74 6c 73 0a 70 61 63 6b 61 67 quire tls.packag
00c0: 65 20 72 65 71 75 69 72 65 20 54 6b 0a 0a 0a 0a e require Tk....
00d0: 23 0a 23 20 43 6f 6e 66 69 67 20 73 65 74 74 69 #.# Config setti
00e0: 6e 67 73 0a 23 0a 73 65 74 20 68 6f 73 74 20 6c ngs.#.set host l
00f0: 6f 63 61 6c 68 6f 73 74 0a 73 65 74 20 70 6f 72 ocalhost.set por
0100: 74 20 39 38 37 36 0a 73 65 74 20 6d 6f 64 65 20 t 9876.set mode
0110: 63 6c 69 65 6e 74 0a 73 65 74 20 63 6c 69 65 6e client.set clien
0120: 74 73 20 5b 6c 69 73 74 5d 0a 73 65 74 20 63 68 ts [list].set ch
0130: 61 6e 20 22 22 0a 0a 73 65 74 20 63 65 72 74 73 an ""..set certs
0140: 44 69 72 09 5b 66 69 6c 65 20 6a 6f 69 6e 20 5b Dir.[file join [
0150: 66 69 6c 65 20 64 69 72 6e 61 6d 65 20 5b 69 6e file dirname [in
0160: 66 6f 20 73 63 72 69 70 74 5d 5d 20 2e 2e 20 74 fo script]] .. t
0170: 65 73 74 73 20 63 65 72 74 73 5d 0a 73 65 74 20 ests certs].set
0180: 73 65 72 76 65 72 43 65 72 74 09 5b 66 69 6c 65 serverCert.[file
0190: 20 6a 6f 69 6e 20 24 63 65 72 74 73 44 69 72 20 join $certsDir
01a0: 73 65 72 76 65 72 2e 70 65 6d 5d 0a 73 65 74 20 server.pem].set
01b0: 63 6c 69 65 6e 74 43 65 72 74 09 5b 66 69 6c 65 clientCert.[file
01c0: 20 6a 6f 69 6e 20 24 63 65 72 74 73 44 69 72 20 join $certsDir
01d0: 63 6c 69 65 6e 74 2e 70 65 6d 5d 0a 73 65 74 20 client.pem].set
01e0: 63 61 43 65 72 74 09 5b 66 69 6c 65 20 6a 6f 69 caCert.[file joi
01f0: 6e 20 24 63 65 72 74 73 44 69 72 20 63 61 2e 70 n $certsDir ca.p
0200: 65 6d 5d 0a 73 65 74 20 73 65 72 76 65 72 4b 65 em].set serverKe
0210: 79 09 5b 66 69 6c 65 20 6a 6f 69 6e 20 24 63 65 y.[file join $ce
0220: 72 74 73 44 69 72 20 73 65 72 76 65 72 2e 6b 65 rtsDir server.ke
0230: 79 5d 0a 73 65 74 20 63 6c 69 65 6e 74 4b 65 79 y].set clientKey
0240: 09 5b 66 69 6c 65 20 6a 6f 69 6e 20 24 63 65 72 .[file join $cer
0250: 74 73 44 69 72 20 63 6c 69 65 6e 74 2e 6b 65 79 tsDir client.key
0260: 5d 0a 0a 0a 0a 23 23 23 23 23 23 23 23 23 23 23 ]....###########
0270: 23 23 23 23 23 23 23 23 23 23 23 23 23 0a 0a 23 #############..#
0280: 0a 23 20 53 65 6e 64 20 6d 65 73 73 61 67 65 0a .# Send message.
0290: 23 0a 70 72 6f 63 20 6d 65 73 73 61 67 65 5f 73 #.proc message_s
02a0: 65 6e 64 20 7b 76 61 72 20 77 7d 20 7b 0a 20 20 end {var w} {.
02b0: 20 20 73 65 74 20 63 68 20 5b 73 65 74 20 24 76 set ch [set $v
02c0: 61 72 5d 0a 20 20 20 20 73 65 74 20 6d 73 67 20 ar]. set msg
02d0: 5b 24 77 20 67 65 74 5d 0a 20 20 20 20 6c 6f 67 [$w get]. log
02e0: 20 24 6d 73 67 20 73 65 6e 64 65 72 0a 20 20 20 $msg sender.
02f0: 20 69 66 20 7b 24 63 68 20 6e 65 20 22 22 7d 20 if {$ch ne ""}
0300: 7b 0a 09 70 75 74 73 20 24 63 68 20 24 6d 73 67 {..puts $ch $msg
0310: 0a 20 20 20 20 7d 0a 20 20 20 20 24 77 20 64 65 . }. $w de
0320: 6c 65 74 65 20 30 20 65 6e 64 0a 7d 0a 0a 23 0a lete 0 end.}..#.
0330: 23 20 52 65 63 65 69 76 65 20 6d 65 73 73 61 67 # Receive messag
0340: 65 0a 23 0a 70 72 6f 63 20 6d 65 73 73 61 67 65 e.#.proc message
0350: 5f 72 65 63 65 69 76 65 20 7b 63 68 7d 20 7b 0a _receive {ch} {.
0360: 20 20 20 20 73 65 74 20 6d 73 67 20 22 22 0a 20 set msg "".
0370: 20 20 20 69 66 20 7b 5b 67 65 74 73 20 24 63 68 if {[gets $ch
0380: 20 6d 73 67 5d 20 3c 3d 20 30 7d 20 7b 0a 09 69 msg] <= 0} {..i
0390: 66 20 7b 5b 65 6f 66 20 24 63 68 5d 7d 20 7b 0a f {[eof $ch]} {.
03a0: 09 20 20 20 20 63 6c 6f 73 65 20 24 63 68 0a 09 . close $ch..
03b0: 20 20 20 20 65 78 69 74 0a 09 7d 0a 20 20 20 20 exit..}.
03c0: 7d 0a 20 20 20 20 69 66 20 7b 5b 73 74 72 69 6e }. if {[strin
03d0: 67 20 6c 65 6e 67 74 68 20 24 6d 73 67 5d 20 3e g length $msg] >
03e0: 20 2d 31 7d 20 7b 0a 09 6c 6f 67 20 24 6d 73 67 -1} {..log $msg
03f0: 20 72 65 63 65 69 76 65 72 0a 20 20 20 20 7d 0a receiver. }.
0400: 7d 0a 0a 23 0a 23 20 43 6f 6e 6e 65 63 74 20 77 }..#.# Connect w
0410: 69 74 68 20 54 4c 53 0a 23 0a 70 72 6f 63 20 63 ith TLS.#.proc c
0420: 6c 69 65 6e 74 5f 63 6f 6e 6e 65 63 74 20 7b 63 lient_connect {c
0430: 68 7d 20 7b 0a 20 20 20 20 74 6c 73 3a 3a 69 6d h} {. tls::im
0440: 70 6f 72 74 20 24 63 68 20 2d 72 65 71 75 65 73 port $ch -reques
0450: 74 20 31 20 2d 72 65 71 75 69 72 65 20 30 0a 20 t 1 -require 0.
0460: 20 20 20 23 74 6c 73 3a 3a 69 6d 70 6f 72 74 20 #tls::import
0470: 24 63 68 20 2d 63 65 72 74 66 69 6c 65 20 24 3a $ch -certfile $:
0480: 3a 63 6c 69 65 6e 74 43 65 72 74 20 2d 63 61 66 :clientCert -caf
0490: 69 6c 65 20 24 3a 3a 63 61 43 65 72 74 20 2d 6b ile $::caCert -k
04a0: 65 79 66 69 6c 65 20 24 3a 3a 63 6c 69 65 6e 74 eyfile $::client
04b0: 4b 65 79 0a 20 20 20 20 74 6c 73 3a 3a 68 61 6e Key. tls::han
04c0: 64 73 68 61 6b 65 20 24 63 68 0a 20 20 20 20 73 dshake $ch. s
04d0: 65 74 20 74 69 6d 65 20 5b 63 6c 6f 63 6b 20 66 et time [clock f
04e0: 6f 72 6d 61 74 20 5b 63 6c 6f 63 6b 20 73 65 63 ormat [clock sec
04f0: 6f 6e 64 73 5d 5d 0a 20 20 20 20 6c 6f 67 20 5b onds]]. log [
0500: 66 6f 72 6d 61 74 20 22 43 6c 69 65 6e 74 20 63 format "Client c
0510: 6f 6e 6e 65 63 74 69 6f 6e 20 66 69 6e 69 73 68 onnection finish
0520: 65 64 20 61 74 20 25 73 22 20 24 74 69 6d 65 5d ed at %s" $time]
0530: 20 6c 6f 63 61 6c 0a 7d 0a 0a 23 0a 23 20 53 65 local.}..#.# Se
0540: 74 75 70 20 63 6c 69 65 6e 74 0a 23 0a 70 72 6f tup client.#.pro
0550: 63 20 63 6c 69 65 6e 74 5f 73 65 74 75 70 20 7b c client_setup {
0560: 7d 20 7b 0a 20 20 20 20 67 6c 6f 62 61 6c 20 68 } {. global h
0570: 6f 73 74 0a 20 20 20 20 67 6c 6f 62 61 6c 20 70 ost. global p
0580: 6f 72 74 0a 20 20 20 20 67 6c 6f 62 61 6c 20 63 ort. global c
0590: 68 61 6e 0a 0a 20 20 20 20 73 65 74 20 63 68 20 han.. set ch
05a0: 5b 73 6f 63 6b 65 74 20 24 68 6f 73 74 20 24 70 [socket $host $p
05b0: 6f 72 74 5d 0a 20 20 20 20 66 63 6f 6e 66 69 67 ort]. fconfig
05c0: 75 72 65 20 24 63 68 20 2d 62 6c 6f 63 6b 69 6e ure $ch -blockin
05d0: 67 20 30 20 2d 62 75 66 66 65 72 69 6e 67 20 6c g 0 -buffering l
05e0: 69 6e 65 20 2d 62 75 66 66 65 72 73 69 7a 65 20 ine -buffersize
05f0: 33 32 37 36 38 20 2d 65 6e 63 6f 64 69 6e 67 20 32768 -encoding
0600: 75 74 66 2d 38 20 2d 74 72 61 6e 73 6c 61 74 69 utf-8 -translati
0610: 6f 6e 20 61 75 74 6f 0a 20 20 20 20 69 66 20 7b on auto. if {
0620: 5b 69 6e 66 6f 20 74 63 6c 76 65 72 73 69 6f 6e [info tclversion
0630: 5d 20 3e 3d 20 39 2e 30 7d 20 7b 0a 09 66 63 6f ] >= 9.0} {..fco
0640: 6e 66 69 67 75 72 65 20 24 63 68 20 2d 6b 65 65 nfigure $ch -kee
0650: 70 61 6c 69 76 65 20 31 20 2d 6e 6f 64 65 6c 61 palive 1 -nodela
0660: 79 20 31 0a 20 20 20 20 7d 0a 20 20 20 20 63 68 y 1. }. ch
0670: 61 6e 20 65 76 65 6e 74 20 24 63 68 20 72 65 61 an event $ch rea
0680: 64 61 62 6c 65 20 5b 6c 69 73 74 20 6d 65 73 73 dable [list mess
0690: 61 67 65 5f 72 65 63 65 69 76 65 20 24 63 68 5d age_receive $ch]
06a0: 0a 20 20 20 20 61 66 74 65 72 20 69 64 6c 65 20 . after idle
06b0: 5b 6c 69 73 74 20 63 6c 69 65 6e 74 5f 63 6f 6e [list client_con
06c0: 6e 65 63 74 20 24 63 68 5d 0a 20 20 20 20 73 65 nect $ch]. se
06d0: 74 20 63 68 61 6e 20 24 63 68 0a 20 20 20 20 72 t chan $ch. r
06e0: 65 74 75 72 6e 20 24 63 68 0a 7d 0a 0a 23 0a 23 eturn $ch.}..#.#
06f0: 20 53 68 75 74 64 6f 77 6e 20 63 6c 69 65 6e 74 Shutdown client
0700: 0a 23 0a 70 72 6f 63 20 63 6c 69 65 6e 74 5f 73 .#.proc client_s
0710: 68 75 74 64 6f 77 6e 20 7b 63 68 7d 20 7b 0a 20 hutdown {ch} {.
0720: 20 20 20 63 6c 6f 73 65 20 24 63 68 0a 7d 0a 0a close $ch.}..
0730: 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 ################
0740: 23 23 23 23 23 23 23 23 0a 0a 23 0a 23 20 41 64 ########..#.# Ad
0750: 64 20 63 6c 69 65 6e 74 20 74 6f 20 63 6c 69 65 d client to clie
0760: 6e 74 20 6c 69 73 74 0a 23 0a 70 72 6f 63 20 61 nt list.#.proc a
0770: 64 64 5f 63 6c 69 65 6e 74 20 7b 63 68 7d 20 7b dd_client {ch} {
0780: 0a 20 20 20 20 67 6c 6f 62 61 6c 20 63 6c 69 65 . global clie
0790: 6e 74 73 0a 0a 20 20 20 20 69 66 20 7b 24 63 68 nts.. if {$ch
07a0: 20 6e 69 20 24 63 6c 69 65 6e 74 73 7d 20 7b 0a ni $clients} {.
07b0: 09 6c 61 70 70 65 6e 64 20 63 6c 69 65 6e 74 73 .lappend clients
07c0: 20 24 63 68 0a 20 20 20 20 7d 0a 7d 0a 0a 23 0a $ch. }.}..#.
07d0: 23 20 52 65 6d 6f 76 65 20 63 6c 69 65 6e 74 20 # Remove client
07e0: 66 72 6f 6d 20 63 6c 69 65 6e 74 20 6c 69 73 74 from client list
07f0: 0a 23 0a 70 72 6f 63 20 72 65 6d 6f 76 65 5f 63 .#.proc remove_c
0800: 6c 69 65 6e 74 20 7b 63 68 7d 20 7b 0a 20 20 20 lient {ch} {.
0810: 20 67 6c 6f 62 61 6c 20 63 6c 69 65 6e 74 73 0a global clients.
0820: 0a 20 20 20 20 69 66 20 7b 24 63 68 20 69 6e 20 . if {$ch in
0830: 24 63 6c 69 65 6e 74 73 7d 20 7b 0a 09 73 65 74 $clients} {..set
0840: 20 69 6e 64 65 78 20 5b 6c 73 65 61 72 63 68 20 index [lsearch
0850: 24 63 6c 69 65 6e 74 73 20 24 63 68 5d 0a 09 73 $clients $ch]..s
0860: 65 74 20 63 6c 69 65 6e 74 73 20 5b 6c 72 65 70 et clients [lrep
0870: 6c 61 63 65 20 24 63 6c 69 65 6e 74 73 20 24 69 lace $clients $i
0880: 6e 64 65 78 20 24 69 6e 64 65 78 5d 0a 20 20 20 ndex $index].
0890: 20 7d 0a 7d 0a 0a 23 0a 23 20 53 65 6e 64 20 6d }.}..#.# Send m
08a0: 65 73 73 61 67 65 0a 23 0a 70 72 6f 63 20 73 65 essage.#.proc se
08b0: 6e 64 5f 61 6c 6c 20 7b 77 7d 20 7b 0a 20 20 20 nd_all {w} {.
08c0: 20 67 6c 6f 62 61 6c 20 63 6c 69 65 6e 74 73 0a global clients.
08d0: 0a 20 20 20 20 73 65 74 20 6d 73 67 20 5b 24 77 . set msg [$w
08e0: 20 67 65 74 5d 0a 20 20 20 20 6c 6f 67 20 24 6d get]. log $m
08f0: 73 67 20 73 65 6e 64 65 72 0a 0a 20 20 20 20 66 sg sender.. f
0900: 6f 72 65 61 63 68 20 63 6c 69 65 6e 74 20 24 63 oreach client $c
0910: 6c 69 65 6e 74 73 20 7b 0a 09 69 66 20 7b 5b 63 lients {..if {[c
0920: 61 74 63 68 20 7b 70 75 74 73 20 24 63 6c 69 65 atch {puts $clie
0930: 6e 74 20 24 6d 73 67 7d 20 65 72 72 5d 7d 20 7b nt $msg} err]} {
0940: 0a 09 20 20 20 20 63 6c 6f 73 65 20 24 63 6c 69 .. close $cli
0950: 65 6e 74 0a 09 20 20 20 20 72 65 6d 6f 76 65 5f ent.. remove_
0960: 63 6c 69 65 6e 74 20 24 63 6c 69 65 6e 74 0a 09 client $client..
0970: 7d 0a 20 20 20 20 7d 0a 20 20 20 20 24 77 20 64 }. }. $w d
0980: 65 6c 65 74 65 20 30 20 65 6e 64 0a 7d 0a 0a 23 elete 0 end.}..#
0990: 0a 23 20 45 63 68 6f 20 72 65 63 65 69 76 65 64 .# Echo received
09a0: 20 6d 65 73 73 61 67 65 73 0a 23 0a 70 72 6f 63 messages.#.proc
09b0: 20 65 63 68 6f 20 7b 63 68 7d 20 7b 0a 20 20 20 echo {ch} {.
09c0: 20 67 6c 6f 62 61 6c 20 63 6c 69 65 6e 74 73 0a global clients.
09d0: 0a 20 20 20 20 69 66 20 7b 5b 67 65 74 73 20 24 . if {[gets $
09e0: 63 68 20 6d 73 67 5d 20 3c 3d 20 30 7d 20 7b 0a ch msg] <= 0} {.
09f0: 09 69 66 20 7b 5b 65 6f 66 20 24 63 68 5d 7d 20 .if {[eof $ch]}
0a00: 7b 0a 09 20 20 20 20 63 6c 6f 73 65 20 24 63 68 {.. close $ch
0a10: 0a 09 20 20 20 20 72 65 6d 6f 76 65 5f 63 6c 69 .. remove_cli
0a20: 65 6e 74 20 24 63 68 0a 09 20 20 20 20 72 65 74 ent $ch.. ret
0a30: 75 72 6e 0a 09 7d 0a 20 20 20 20 7d 0a 20 20 20 urn..}. }.
0a40: 20 6c 6f 67 20 24 6d 73 67 20 72 65 63 65 69 76 log $msg receiv
0a50: 65 72 0a 0a 20 20 20 20 66 6f 72 65 61 63 68 20 er.. foreach
0a60: 63 6c 69 65 6e 74 20 24 63 6c 69 65 6e 74 73 20 client $clients
0a70: 7b 0a 09 69 66 20 7b 5b 63 61 74 63 68 20 7b 70 {..if {[catch {p
0a80: 75 74 73 20 24 63 6c 69 65 6e 74 20 24 6d 73 67 uts $client $msg
0a90: 7d 20 65 72 72 5d 7d 20 7b 0a 09 20 20 20 20 63 } err]} {.. c
0aa0: 6c 6f 73 65 20 24 63 6c 69 65 6e 74 0a 09 20 20 lose $client..
0ab0: 20 20 72 65 6d 6f 76 65 5f 63 6c 69 65 6e 74 20 remove_client
0ac0: 24 63 6c 69 65 6e 74 0a 09 7d 0a 20 20 20 20 7d $client..}. }
0ad0: 0a 7d 0a 0a 23 0a 23 20 41 63 63 65 70 74 20 63 .}..#.# Accept c
0ae0: 6c 69 65 6e 74 20 63 6f 6e 6e 65 63 74 69 6f 6e lient connection
0af0: 73 0a 23 0a 70 72 6f 63 20 61 63 63 65 70 74 20 s.#.proc accept
0b00: 7b 63 68 20 61 64 64 72 20 70 6f 72 74 7d 20 7b {ch addr port} {
0b10: 0a 20 20 20 20 61 64 64 5f 63 6c 69 65 6e 74 20 . add_client
0b20: 24 63 68 0a 20 20 20 20 73 65 74 20 74 69 6d 65 $ch. set time
0b30: 20 5b 63 6c 6f 63 6b 20 66 6f 72 6d 61 74 20 5b [clock format [
0b40: 63 6c 6f 63 6b 20 73 65 63 6f 6e 64 73 5d 5d 0a clock seconds]].
0b50: 0a 20 20 20 20 66 63 6f 6e 66 69 67 75 72 65 20 . fconfigure
0b60: 24 63 68 20 2d 62 6c 6f 63 6b 69 6e 67 20 30 20 $ch -blocking 0
0b70: 2d 62 75 66 66 65 72 69 6e 67 20 6c 69 6e 65 20 -buffering line
0b80: 2d 62 75 66 66 65 72 73 69 7a 65 20 33 32 37 36 -buffersize 3276
0b90: 38 20 2d 65 6e 63 6f 64 69 6e 67 20 75 74 66 2d 8 -encoding utf-
0ba0: 38 20 2d 74 72 61 6e 73 6c 61 74 69 6f 6e 20 61 8 -translation a
0bb0: 75 74 6f 0a 20 20 20 20 6c 6f 67 20 5b 66 6f 72 uto. log [for
0bc0: 6d 61 74 20 22 41 63 63 65 70 74 65 64 20 63 6c mat "Accepted cl
0bd0: 69 65 6e 74 20 63 6f 6e 6e 65 63 74 69 6f 6e 20 ient connection
0be0: 66 72 6f 6d 20 25 73 20 6f 6e 20 70 6f 72 74 20 from %s on port
0bf0: 25 64 20 61 74 20 25 73 22 20 24 61 64 64 72 20 %d at %s" $addr
0c00: 24 70 6f 72 74 20 24 74 69 6d 65 5d 20 6c 6f 63 $port $time] loc
0c10: 61 6c 0a 0a 20 20 20 20 74 6c 73 3a 3a 69 6d 70 al.. tls::imp
0c20: 6f 72 74 20 24 63 68 20 2d 73 65 72 76 65 72 20 ort $ch -server
0c30: 31 20 2d 63 65 72 74 66 69 6c 65 20 24 3a 3a 73 1 -certfile $::s
0c40: 65 72 76 65 72 43 65 72 74 20 2d 63 61 66 69 6c erverCert -cafil
0c50: 65 20 24 3a 3a 63 61 43 65 72 74 20 2d 6b 65 79 e $::caCert -key
0c60: 66 69 6c 65 20 24 3a 3a 73 65 72 76 65 72 4b 65 file $::serverKe
0c70: 79 0a 20 20 20 20 63 68 61 6e 20 65 76 65 6e 74 y. chan event
0c80: 20 24 63 68 20 72 65 61 64 61 62 6c 65 20 5b 6c $ch readable [l
0c90: 69 73 74 20 65 63 68 6f 20 24 63 68 5d 0a 20 20 ist echo $ch].
0ca0: 20 20 70 75 74 73 20 24 63 68 20 5b 66 6f 72 6d puts $ch [form
0cb0: 61 74 20 22 43 6f 6e 6e 65 63 74 65 64 20 74 6f at "Connected to
0cc0: 20 73 65 72 76 65 72 20 61 74 20 25 73 22 20 24 server at %s" $
0cd0: 74 69 6d 65 5d 0a 7d 0a 0a 23 0a 23 20 53 65 74 time].}..#.# Set
0ce0: 75 70 20 73 65 72 76 65 72 0a 23 0a 70 72 6f 63 up server.#.proc
0cf0: 20 73 65 72 76 65 72 5f 73 65 74 75 70 20 7b 7d server_setup {}
0d00: 20 7b 0a 20 20 20 20 67 6c 6f 62 61 6c 20 70 6f {. global po
0d10: 72 74 0a 20 20 20 20 67 6c 6f 62 61 6c 20 63 68 rt. global ch
0d20: 61 6e 0a 0a 20 20 20 20 73 65 74 20 63 68 20 5b an.. set ch [
0d30: 73 6f 63 6b 65 74 20 2d 73 65 72 76 65 72 20 61 socket -server a
0d40: 63 63 65 70 74 20 24 70 6f 72 74 5d 0a 20 20 20 ccept $port].
0d50: 20 66 63 6f 6e 66 69 67 75 72 65 20 24 63 68 20 fconfigure $ch
0d60: 2d 62 6c 6f 63 6b 69 6e 67 20 30 20 2d 62 75 66 -blocking 0 -buf
0d70: 66 65 72 69 6e 67 20 6c 69 6e 65 20 2d 62 75 66 fering line -buf
0d80: 66 65 72 73 69 7a 65 20 33 32 37 36 38 20 2d 65 fersize 32768 -e
0d90: 6e 63 6f 64 69 6e 67 20 75 74 66 2d 38 20 2d 74 ncoding utf-8 -t
0da0: 72 61 6e 73 6c 61 74 69 6f 6e 20 61 75 74 6f 0a ranslation auto.
0db0: 20 20 20 20 69 66 20 7b 5b 69 6e 66 6f 20 74 63 if {[info tc
0dc0: 6c 76 65 72 73 69 6f 6e 5d 20 3e 3d 20 39 2e 30 lversion] >= 9.0
0dd0: 7d 20 7b 0a 09 66 63 6f 6e 66 69 67 75 72 65 20 } {..fconfigure
0de0: 24 63 68 20 2d 6b 65 65 70 61 6c 69 76 65 20 31 $ch -keepalive 1
0df0: 20 2d 6e 6f 64 65 6c 61 79 20 31 0a 20 20 20 20 -nodelay 1.
0e00: 7d 0a 20 20 20 20 73 65 74 20 63 68 61 6e 20 24 }. set chan $
0e10: 63 68 0a 20 20 20 20 72 65 74 75 72 6e 20 24 63 ch. return $c
0e20: 68 0a 7d 0a 0a 23 0a 23 20 53 68 75 74 64 6f 77 h.}..#.# Shutdow
0e30: 6e 20 73 65 72 76 65 72 0a 23 0a 70 72 6f 63 20 n server.#.proc
0e40: 73 65 72 76 65 72 5f 73 68 75 74 64 6f 77 6e 20 server_shutdown
0e50: 7b 63 68 7d 20 7b 0a 20 20 20 20 67 6c 6f 62 61 {ch} {. globa
0e60: 6c 20 63 6c 69 65 6e 74 73 0a 0a 20 20 20 20 66 l clients.. f
0e70: 6f 72 65 61 63 68 20 63 6c 69 65 6e 74 20 24 63 oreach client $c
0e80: 6c 69 65 6e 74 73 20 7b 0a 09 63 6c 6f 73 65 20 lients {..close
0e90: 24 63 6c 69 65 6e 74 0a 20 20 20 20 7d 0a 20 20 $client. }.
0ea0: 20 20 63 6c 6f 73 65 20 24 63 68 0a 7d 0a 0a 23 close $ch.}..#
0eb0: 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 23 ################
0ec0: 23 23 23 23 23 23 23 0a 0a 23 0a 23 20 4c 6f 67 #######..#.# Log
0ed0: 20 6d 65 73 73 61 67 65 0a 23 0a 70 72 6f 63 20 message.#.proc
0ee0: 74 65 78 74 5f 75 70 64 61 74 65 20 7b 77 20 6d text_update {w m
0ef0: 73 67 20 74 61 67 7d 20 7b 0a 20 20 20 20 24 77 sg tag} {. $w
0f00: 20 69 6e 73 65 72 74 20 65 6e 64 20 24 6d 73 67 insert end $msg
0f10: 5c 6e 20 24 74 61 67 0a 20 20 20 20 24 77 20 79 \n $tag. $w y
0f20: 76 69 65 77 20 6d 6f 76 65 74 6f 20 31 2e 30 0a view moveto 1.0.
0f30: 7d 0a 0a 23 0a 23 20 43 72 65 61 74 65 20 47 55 }..#.# Create GU
0f40: 49 0a 23 0a 70 72 6f 63 20 73 65 74 75 70 5f 67 I.#.proc setup_g
0f50: 75 69 20 7b 77 20 6d 6f 64 65 7d 20 7b 0a 20 20 ui {w mode} {.
0f60: 20 20 77 6d 20 74 69 74 6c 65 20 24 77 20 5b 66 wm title $w [f
0f70: 6f 72 6d 61 74 20 22 43 68 61 74 20 25 73 20 4d ormat "Chat %s M
0f80: 6f 64 65 22 20 5b 73 74 72 69 6e 67 20 74 6f 74 ode" [string tot
0f90: 69 74 6c 65 20 24 6d 6f 64 65 5d 5d 0a 0a 20 20 itle $mode]]..
0fa0: 20 20 67 72 69 64 20 63 6f 6c 75 6d 6e 63 6f 6e grid columncon
0fb0: 66 69 67 75 72 65 20 24 77 20 30 20 2d 77 65 69 figure $w 0 -wei
0fc0: 67 68 74 20 31 0a 20 20 20 20 67 72 69 64 20 72 ght 1. grid r
0fd0: 6f 77 63 6f 6e 66 69 67 75 72 65 20 24 77 20 30 owconfigure $w 0
0fe0: 20 2d 77 65 69 67 68 74 20 31 0a 0a 20 20 20 20 -weight 1..
0ff0: 23 20 4d 65 73 73 61 67 65 73 20 66 72 61 6d 65 # Messages frame
1000: 0a 20 20 20 20 73 65 74 20 66 20 5b 74 74 6b 3a . set f [ttk:
1010: 3a 66 72 61 6d 65 20 24 7b 77 7d 6d 73 67 73 5d :frame ${w}msgs]
1020: 0a 20 20 20 20 67 72 69 64 20 24 66 20 2d 73 74 . grid $f -st
1030: 69 63 6b 79 20 6e 73 65 77 0a 20 20 20 20 67 72 icky nsew. gr
1040: 69 64 20 63 6f 6c 75 6d 6e 63 6f 6e 66 69 67 75 id columnconfigu
1050: 72 65 20 24 66 20 30 20 2d 77 65 69 67 68 74 20 re $f 0 -weight
1060: 31 0a 20 20 20 20 67 72 69 64 20 72 6f 77 63 6f 1. grid rowco
1070: 6e 66 69 67 75 72 65 20 24 66 20 30 20 2d 77 65 nfigure $f 0 -we
1080: 69 67 68 74 20 31 0a 0a 20 20 20 20 73 65 74 20 ight 1.. set
1090: 74 20 5b 74 65 78 74 20 24 66 2e 74 65 78 74 20 t [text $f.text
10a0: 2d 79 73 63 72 6f 6c 6c 63 6f 6d 6d 61 6e 64 20 -yscrollcommand
10b0: 5b 6c 69 73 74 20 24 66 2e 76 73 62 20 73 65 74 [list $f.vsb set
10c0: 5d 5d 0a 20 20 20 20 23 20 20 2d 78 73 63 72 6f ]]. # -xscro
10d0: 6c 6c 63 6f 6d 6d 61 6e 64 20 5b 6c 69 73 74 20 llcommand [list
10e0: 24 66 2e 68 73 62 20 73 65 74 5d 0a 20 20 20 20 $f.hsb set].
10f0: 23 73 65 74 20 73 68 20 5b 74 74 6b 3a 3a 73 63 #set sh [ttk::sc
1100: 72 6f 6c 6c 62 61 72 20 24 66 2e 68 73 62 20 2d rollbar $f.hsb -
1110: 63 6f 6d 6d 61 6e 64 20 5b 6c 69 73 74 20 24 74 command [list $t
1120: 20 78 76 69 65 77 5d 20 2d 6f 72 69 65 6e 74 20 xview] -orient
1130: 68 6f 72 69 7a 6f 6e 74 61 6c 5d 0a 20 20 20 20 horizontal].
1140: 73 65 74 20 73 76 20 5b 74 74 6b 3a 3a 73 63 72 set sv [ttk::scr
1150: 6f 6c 6c 62 61 72 20 24 66 2e 76 73 62 20 2d 63 ollbar $f.vsb -c
1160: 6f 6d 6d 61 6e 64 20 5b 6c 69 73 74 20 24 74 20 ommand [list $t
1170: 79 76 69 65 77 5d 20 2d 6f 72 69 65 6e 74 20 76 yview] -orient v
1180: 65 72 74 69 63 61 6c 5d 0a 20 20 20 20 67 72 69 ertical]. gri
1190: 64 20 24 74 20 2d 72 6f 77 20 30 20 2d 63 6f 6c d $t -row 0 -col
11a0: 75 6d 6e 20 30 20 2d 73 74 69 63 6b 79 20 6e 73 umn 0 -sticky ns
11b0: 65 77 0a 20 20 20 20 67 72 69 64 20 24 73 76 20 ew. grid $sv
11c0: 2d 72 6f 77 20 30 20 2d 63 6f 6c 75 6d 6e 20 31 -row 0 -column 1
11d0: 20 2d 73 74 69 63 6b 79 20 6e 73 65 77 0a 20 20 -sticky nsew.
11e0: 20 20 23 67 72 69 64 20 24 73 68 20 2d 72 6f 77 #grid $sh -row
11f0: 20 31 20 2d 63 6f 6c 75 6d 6e 20 30 20 2d 73 74 1 -column 0 -st
1200: 69 63 6b 79 20 6e 73 65 77 0a 20 20 20 20 69 6e icky nsew. in
1210: 74 65 72 70 20 61 6c 69 61 73 20 7b 7d 20 6c 6f terp alias {} lo
1220: 67 20 7b 7d 20 74 65 78 74 5f 75 70 64 61 74 65 g {} text_update
1230: 20 24 74 0a 0a 20 20 20 20 23 20 43 72 65 61 74 $t.. # Creat
1240: 65 20 74 61 67 73 0a 20 20 20 20 24 74 20 74 61 e tags. $t ta
1250: 67 20 63 6f 6e 66 69 67 75 72 65 20 73 65 6e 64 g configure send
1260: 65 72 20 2d 62 61 63 6b 67 72 6f 75 6e 64 20 6c er -background l
1270: 69 67 68 74 62 6c 75 65 20 2d 66 6f 72 65 67 72 ightblue -foregr
1280: 6f 75 6e 64 20 62 6c 61 63 6b 20 2d 6a 75 73 74 ound black -just
1290: 69 66 79 20 72 69 67 68 74 20 5c 0a 09 2d 6c 6d ify right \..-lm
12a0: 61 72 67 69 6e 31 20 31 30 30 20 2d 6c 6d 61 72 argin1 100 -lmar
12b0: 67 69 6e 32 20 31 30 30 20 2d 6c 6d 61 72 67 69 gin2 100 -lmargi
12c0: 6e 63 6f 6c 6f 72 20 77 68 69 74 65 20 2d 73 70 ncolor white -sp
12d0: 61 63 69 6e 67 31 20 31 35 20 2d 77 72 61 70 20 acing1 15 -wrap
12e0: 77 6f 72 64 0a 20 20 20 20 24 74 20 74 61 67 20 word. $t tag
12f0: 63 6f 6e 66 69 67 75 72 65 20 72 65 63 65 69 76 configure receiv
1300: 65 72 20 2d 62 61 63 6b 67 72 6f 75 6e 64 20 6c er -background l
1310: 69 67 68 74 67 72 61 79 20 2d 66 6f 72 65 67 72 ightgray -foregr
1320: 6f 75 6e 64 20 62 6c 61 63 6b 20 2d 6a 75 73 74 ound black -just
1330: 69 66 79 20 6c 65 66 74 20 5c 0a 09 2d 72 6d 61 ify left \..-rma
1340: 72 67 69 6e 20 31 30 30 20 2d 72 6d 61 72 67 69 rgin 100 -rmargi
1350: 6e 63 6f 6c 6f 72 20 77 68 69 74 65 20 2d 73 70 ncolor white -sp
1360: 61 63 69 6e 67 31 20 31 35 20 2d 77 72 61 70 20 acing1 15 -wrap
1370: 77 6f 72 64 0a 20 20 20 20 24 74 20 74 61 67 20 word. $t tag
1380: 63 6f 6e 66 69 67 75 72 65 20 6c 6f 63 61 6c 20 configure local
1390: 2d 62 61 63 6b 67 72 6f 75 6e 64 20 77 68 69 74 -background whit
13a0: 65 20 2d 66 6f 72 65 67 72 6f 75 6e 64 20 62 6c e -foreground bl
13b0: 61 63 6b 20 2d 6a 75 73 74 69 66 79 20 6c 65 66 ack -justify lef
13c0: 74 20 5c 0a 09 2d 73 70 61 63 69 6e 67 31 20 31 t \..-spacing1 1
13d0: 35 20 2d 77 72 61 70 20 77 6f 72 64 0a 0a 20 20 5 -wrap word..
13e0: 20 20 23 20 53 65 6e 64 20 66 72 61 6d 65 0a 20 # Send frame.
13f0: 20 20 20 73 65 74 20 66 20 5b 74 74 6b 3a 3a 66 set f [ttk::f
1400: 72 61 6d 65 20 24 7b 77 7d 73 65 6e 64 5d 0a 20 rame ${w}send].
1410: 20 20 20 67 72 69 64 20 24 66 20 2d 73 74 69 63 grid $f -stic
1420: 6b 79 20 6e 73 65 77 0a 20 20 20 20 67 72 69 64 ky nsew. grid
1430: 20 63 6f 6c 75 6d 6e 63 6f 6e 66 69 67 75 72 65 columnconfigure
1440: 20 24 66 20 30 20 2d 77 65 69 67 68 74 20 31 0a $f 0 -weight 1.
1450: 20 20 20 20 67 72 69 64 20 72 6f 77 63 6f 6e 66 grid rowconf
1460: 69 67 75 72 65 20 24 66 20 30 20 2d 77 65 69 67 igure $f 0 -weig
1470: 68 74 20 31 0a 0a 20 20 20 20 73 65 74 20 65 20 ht 1.. set e
1480: 5b 74 74 6b 3a 3a 65 6e 74 72 79 20 24 66 2e 65 [ttk::entry $f.e
1490: 20 2d 78 73 63 72 6f 6c 6c 63 6f 6d 6d 61 6e 64 -xscrollcommand
14a0: 20 5b 6c 69 73 74 20 24 66 2e 68 73 62 20 73 65 [list $f.hsb se
14b0: 74 5d 5d 0a 20 20 20 20 69 66 20 7b 24 6d 6f 64 t]]. if {$mod
14c0: 65 20 65 71 20 22 63 6c 69 65 6e 74 22 7d 20 7b e eq "client"} {
14d0: 0a 09 73 65 74 20 63 6d 64 20 5b 6c 69 73 74 20 ..set cmd [list
14e0: 6d 65 73 73 61 67 65 5f 73 65 6e 64 20 3a 3a 63 message_send ::c
14f0: 68 61 6e 20 24 65 5d 0a 20 20 20 20 7d 20 65 6c han $e]. } el
1500: 73 65 20 7b 0a 09 73 65 74 20 63 6d 64 20 5b 6c se {..set cmd [l
1510: 69 73 74 20 73 65 6e 64 5f 61 6c 6c 20 24 65 5d ist send_all $e]
1520: 0a 20 20 20 20 7d 0a 20 20 20 20 73 65 74 20 62 . }. set b
1530: 20 5b 74 74 6b 3a 3a 62 75 74 74 6f 6e 20 24 66 [ttk::button $f
1540: 2e 62 20 2d 63 6f 6d 6d 61 6e 64 20 24 63 6d 64 .b -command $cmd
1550: 20 2d 74 65 78 74 20 22 53 65 6e 64 22 5d 0a 20 -text "Send"].
1560: 20 20 20 62 69 6e 64 20 24 65 20 3c 52 65 74 75 bind $e <Retu
1570: 72 6e 3e 20 24 63 6d 64 0a 20 20 20 20 73 65 74 rn> $cmd. set
1580: 20 73 68 20 5b 74 74 6b 3a 3a 73 63 72 6f 6c 6c sh [ttk::scroll
1590: 62 61 72 20 24 66 2e 68 73 62 20 2d 63 6f 6d 6d bar $f.hsb -comm
15a0: 61 6e 64 20 5b 6c 69 73 74 20 24 65 20 78 76 69 and [list $e xvi
15b0: 65 77 20 73 63 72 6f 6c 6c 5d 20 2d 6f 72 69 65 ew scroll] -orie
15c0: 6e 74 20 68 6f 72 69 7a 6f 6e 74 61 6c 5d 0a 20 nt horizontal].
15d0: 20 20 20 67 72 69 64 20 24 65 20 2d 72 6f 77 20 grid $e -row
15e0: 30 20 2d 63 6f 6c 75 6d 6e 20 30 20 2d 73 74 69 0 -column 0 -sti
15f0: 63 6b 79 20 6e 73 65 77 0a 20 20 20 20 67 72 69 cky nsew. gri
1600: 64 20 24 62 20 2d 72 6f 77 20 30 20 2d 63 6f 6c d $b -row 0 -col
1610: 75 6d 6e 20 31 20 2d 73 74 69 63 6b 79 20 6e 73 umn 1 -sticky ns
1620: 65 77 0a 20 20 20 20 67 72 69 64 20 24 73 68 20 ew. grid $sh
1630: 2d 72 6f 77 20 31 20 2d 63 6f 6c 75 6d 6e 20 30 -row 1 -column 0
1640: 20 2d 73 74 69 63 6b 79 20 6e 73 65 77 0a 0a 20 -sticky nsew..
1650: 20 20 20 77 6d 20 70 72 6f 74 6f 63 6f 6c 20 24 wm protocol $
1660: 77 20 57 4d 5f 44 45 4c 45 54 45 5f 57 49 4e 44 w WM_DELETE_WIND
1670: 4f 57 20 73 68 75 74 64 6f 77 6e 0a 7d 0a 0a 23 OW shutdown.}..#
1680: 0a 23 20 53 68 75 74 64 6f 77 6e 0a 23 0a 70 72 .# Shutdown.#.pr
1690: 6f 63 20 73 68 75 74 64 6f 77 6e 20 7b 7d 20 7b oc shutdown {} {
16a0: 0a 20 20 20 20 67 6c 6f 62 61 6c 20 6d 6f 64 65 . global mode
16b0: 0a 0a 20 20 20 20 69 66 20 7b 24 6d 6f 64 65 20 .. if {$mode
16c0: 65 71 20 22 63 6c 69 65 6e 74 22 7d 20 7b 0a 09 eq "client"} {..
16d0: 63 6c 69 65 6e 74 5f 73 68 75 74 64 6f 77 6e 20 client_shutdown
16e0: 24 3a 3a 63 68 61 6e 0a 20 20 20 20 7d 20 65 6c $::chan. } el
16f0: 73 65 20 7b 0a 09 73 65 72 76 65 72 5f 73 68 75 se {..server_shu
1700: 74 64 6f 77 6e 20 24 3a 3a 63 68 61 6e 0a 20 20 tdown $::chan.
1710: 20 20 7d 0a 20 20 20 20 65 78 69 74 0a 7d 0a 0a }. exit.}..
1720: 23 0a 23 20 53 74 61 72 74 20 63 6c 69 65 6e 74 #.# Start client
1730: 20 6f 72 20 73 65 72 76 65 72 0a 23 0a 70 72 6f or server.#.pro
1740: 63 20 6d 61 69 6e 20 7b 61 72 67 73 7d 20 7b 0a c main {args} {.
1750: 20 20 20 20 67 6c 6f 62 61 6c 20 6d 6f 64 65 0a global mode.
1760: 0a 20 20 20 20 69 66 20 7b 22 2d 63 6c 69 65 6e . if {"-clien
1770: 74 22 20 69 6e 20 24 61 72 67 73 7d 20 7b 0a 09 t" in $args} {..
1780: 73 65 74 20 6d 6f 64 65 20 63 6c 69 65 6e 74 0a set mode client.
1790: 09 73 65 74 20 63 6d 64 20 5b 6c 69 73 74 20 63 .set cmd [list c
17a0: 6c 69 65 6e 74 5f 73 65 74 75 70 5d 0a 20 20 20 lient_setup].
17b0: 20 7d 20 65 6c 73 65 20 7b 0a 09 73 65 74 20 6d } else {..set m
17c0: 6f 64 65 20 73 65 72 76 65 72 0a 09 73 65 74 20 ode server..set
17d0: 63 6d 64 20 5b 6c 69 73 74 20 73 65 72 76 65 72 cmd [list server
17e0: 5f 73 65 74 75 70 5d 0a 20 20 20 20 7d 0a 20 20 _setup]. }.
17f0: 20 20 73 65 74 75 70 5f 67 75 69 20 2e 20 24 6d setup_gui . $m
1800: 6f 64 65 0a 20 20 20 20 61 66 74 65 72 20 31 30 ode. after 10
1810: 30 30 20 24 63 6d 64 0a 20 20 20 20 76 77 61 69 00 $cmd. vwai
1820: 74 20 64 6f 6e 65 0a 7d 0a 0a 6d 61 69 6e 20 7b t done.}..main {
1830: 2a 7d 24 3a 3a 61 72 67 76 0a *}$::argv.