#!/usr/bin/env wish proc createTerm {sock} { global socket port toplevel .$sock text .$sock.t -yscrollcommand ".$sock.v set" scrollbar .$sock.v -command ".$sock.t yview" .$sock.t tag configure output -foreground red .$sock.t tag configure input -foreground darkgreen grid rowconfigure .$sock 0 -weight 1 grid columnconfigure .$sock 0 -weight 1 grid .$sock.t .$sock.v -sticky nsew bind .$sock.t "close $sock; unset socket(.$sock.t)" bind .$sock.t "%W delete 0.1 end" set socket(.$sock.t) $sock focus .$sock.t wm title .$sock "port $port <-> [fconfigure $sock -peername]" } proc connect {sock addr port} { fconfigure $sock -blocking 0 -buffering none -translation binary createTerm $sock fileevent $sock readable "receiveHandler $sock" } proc escape {string} { while {![string is print -failindex index $string]} { set char [string index $string $index] scan $char "%c" code switch $char { "\r" { set escaped "\\r" } "\n" { set escaped "\\n" } "\a" { set escaped "\\a" } "\t" { set escaped "\\t" } default { set escaped [format "<%02x>" $code] } } set string [string replace $string $index $index $escaped] } return $string } proc sendReply {sock text} { catch { # ignore that socket may already be closed .$sock.t mark set insert end .$sock.t insert end $text .$sock.t see end puts -nonewline $sock $text } } proc checkNum {n} { if {[string is integer $n] && $n >= 0} {return $n} return -code error "argument $n must be a positive number" } proc receiveHandler {sock} { set a [read $sock] if [eof $sock] { destroy .$sock return } .$sock.t mark set insert end .$sock.t insert end $a output .$sock.t see end set l [split $a] if [catch { switch -- [lindex $l 0] { "exit" { exit } "disconnect" { sendReply $sock [string range $a 11 end] destroy .$sock } "echo" { sendReply $sock [string range $a 5 end] } "binary" { set x [checkNum [lindex $l 1]] sendReply $sock [format %c $x] } "longmsg" { set length [checkNum [lindex $l 1]] sendReply $sock "[string range x[string repeat 0123456789abcdefghijklmnopqrstuvwxyz [expr $length / 36 + 1]] 1 $length]\n" } "wait" { set wait [checkNum [lindex $l 1]] after $wait [list sendReply $sock "Done\n"] } "start" { set wait [checkNum [lindex $l 1]] set ::counter 0 after $wait [list sendAsync $wait "[string range $a [string wordend $a 7] end]"] sendReply $sock "Started\n" } "stop" { set ::counter -1 sendReply $sock "Stopped\n" } "set" { set ::values([lindex $a 1]) [lrange $l 2 end-1] sendReply $sock "Ok\n" } "get" { if [info exists ::values([lindex $l 1])] { sendReply $sock "[lindex $l 1] $::values([lindex $l 1])\n" } else { sendReply $sock "ERROR: [lindex $l 1] not found\n" } } "help" { sendReply $sock "help this text\n" sendReply $sock "echo string reply string\n" sendReply $sock "binary number reply byte with value number\n" sendReply $sock "longmsg length reply string with length characters\n" sendReply $sock "wait msec reply \"Done\" after some time\n" sendReply $sock "start msec start sending messages priodically\n" sendReply $sock "stop stop sending messages\n" sendReply $sock "set key value store a value into variable key\n" sendReply $sock "get key reply previously stored value from key\n" sendReply $sock "disconnect close connection\n" sendReply $sock "exit kill terminal server\n" } } } msg] { sendReply $sock "ERROR: $msg\n" puts stderr $::errorInfo } } proc sendAsync {wait message} { if {$::counter < 0} return foreach term [array names ::socket] { sendReply $::socket($term) "Message number [incr ::counter]$message"; } after $wait sendAsync $wait [list $message] } if {[info proc tkTextInsert] != ""} { set insert tkTextInsert set paste tkTextPaste set pastesel tkPasteSelection } else { set insert tk::TextInsert set paste tk_textPaste set pastesel ::tk::TextPasteSelection } rename $insert tkTextInsert_org rename $paste tkTextPaste_org rename $pastesel tkTextPasteSel_org proc $insert {w s} { global socket if {[string equal $s ""] || [string equal [$w cget -state] "disabled"]} { return } sendReply $socket($w) $s } proc $paste {w x y} { puts [list paste $w $s] global insert set s [selection get -displayof $w] $insert $w $s } proc $pastesel {w x y} { global insert $w mark set insert [TextClosestGap $w $x $y] if {![catch {::tk::GetSelection $w PRIMARY} sel]} { set oldSeparator [$w cget -autoseparators] if {$oldSeparator} { $w configure -autoseparators 0 $w edit separator } $insert $w $sel if {$oldSeparator} { $w edit separator $w configure -autoseparators 1 } } if {[$w cget -state] eq "normal"} {focus $w} } #remove bindings on Control- for {set ascii 0x61} {$ascii <= 0x7a} {incr ascii} { bind Text "" } #remove bindings on symbolic tags foreach tag {Clear Paste Copy Cut} { bind Text <<$tag>> "" } bind Text [list $insert %W %A] set port [lindex $argv 0] if {$port == ""} { set port 40000 } if [catch { socket -server connect $port } msg ] { return -code error "$msg (port $port)" } label .info -text "Accepting connections on port $port" button .exit -text "Exit" -command exit pack .info .exit -expand yes -fill x