# -*- tcl -*- # Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from -buildversion.txt # module template: shellspy/src/decktemplates/vendor/punk/modules/template_module-0.0.2.tm # # Please consider using a BSD or MIT style license for greatest compatibility with the Tcl ecosystem. # Code using preferred Tcl licenses can be eligible for inclusion in Tcllib, Tklib and the punk package repository. # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # (C) 2024 # # @@ Meta Begin # Application punk::basictelnet 999999.0a1.0 # Meta platform tcl # Meta license # @@ Meta End # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # doctools header # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[manpage_begin shellspy_module_punk::basictelnet 0 999999.0a1.0] #[copyright "2024"] #[titledesc {basic telnet client - DKF/Wiki}] [comment {-- Name section and table of contents description --}] #[moddesc {basic telnet client}] [comment {-- Description at end of page heading --}] #[require punk::basictelnet] #[keywords module] #[description] #[para] see https://wiki.tcl-lang.org/page/Tcl+Telnet # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Overview] #[para] overview of punk::basictelnet #[subsection Concepts] #[para] - # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Requirements # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[subsection dependencies] #[para] packages used by punk::basictelnet #[list_begin itemized] package require Tcl 8.6- #*** !doctools #[item] [package {Tcl 8.6}] # #package require frobz # #*** !doctools # #[item] [package {frobz}] #*** !doctools #[list_end] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section API] # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # oo::class namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::basictelnet::class { #*** !doctools #[subsection {Namespace punk::basictelnet::class}] #[para] class definitions if {[info commands [namespace current]::interface_sample1] eq ""} { #*** !doctools #[list_begin enumerated] # oo::class create interface_sample1 { # #*** !doctools # #[enum] CLASS [class interface_sample1] # #[list_begin definitions] # method test {arg1} { # #*** !doctools # #[call class::interface_sample1 [method test] [arg arg1]] # #[para] test method # puts "test: $arg1" # } # #*** !doctools # #[list_end] [comment {-- end definitions interface_sample1}] # } #*** !doctools #[list_end] [comment {--- end class enumeration ---}] } } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Base namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::basictelnet { namespace export * variable closed variable consolewidth ;#entire console width - checked only at each telnet start for performance reasons (as we don't yet have sigwinch for unix, and on windows we don't yet have an equivalent) #consolewidth should be about 80 cols wider than the window_cols setting if debug on same screen is to be used. (debug pane on RHS of screen) #todo - launch a separate telnet server (or something) and allow debugging to a totally separate window that can be monitored with another telnet client - review #todo - use these as defaults - provide a way to configure/listen to local events and notify server (sigwinch unix, unknown windows) set window_cols 80 set window_rows 25 #Some modern(?) telnet servers seem to just pump out utf-8 encoded graphics by default - without negotiating or confirming binary etc? review variable encoding_guess utf-8 #we will experimentally assume utf-8 - which should handle ascii fine - and flip to cp437 when data encountered that cannot be valid utf-8 #todo - proper charset negotiation variable debug set debug 0 proc debug {{on_off ""}} { variable debug if {$on_off eq ""} { return $debug } if {![string is boolean -strict $on_off]} { error "punk::basictelnet::debug on_off must be empty string to query, or a boolean value" } set debug [expr {$on_off}] } variable can_debug set can_debug 1 if {[catch { package require textblock package require punk::lib package require punk::ansi package require punk::char package require punk::console package require overtype #and whatever these depend on! } errMsg]} { set can_debug 0 } #variable terminal_type "ANSI" variable terminal_type "VT100" #try: DUMB,ANSI,VT100,XTERM #see also the Mud Terminal Type Standard as an extensiont to RFC1091 Telenet Terminal-Type #https://tintin.mudhalla.net/protocols/mtts/ variable remote_terminal_type set remote_terminal_type "" ;#empty until/unless reported via an option 24 send from the remote #*** !doctools #[subsection {Namespace punk::basictelnet}] #[para] Core API functions for punk::basictelnet #[list_begin definitions] variable optioncodes dict set optioncodes 0 [list name "Binary Transmission" short "bin"] dict set optioncodes 1 [list name "Echo" short "echo"] dict set optioncodes 2 [list name "Reconnection" short "recon"] dict set optioncodes 3 [list name "Suppress Go Ahead" short "Suppress GA"] dict set optioncodes 4 [list name "Approx Message Size Negotiation" short "msgsize nego"] dict set optioncodes 5 [list name "Status" short "status"] ;#RFC 859 dict set optioncodes 6 [list name "Timing Mark" short "tmark"] dict set optioncodes 7 [list name "Remote Controlled Trans and Echo"] dict set optioncodes 8 [list name "Output Line Width"] dict set optioncodes 9 [list name "Output Page Size"] dict set optioncodes 10 [list name "Output Carriage-Return Disposition"] dict set optioncodes 11 [list name "Output Horizontal Tab Stops"] dict set optioncodes 12 [list name "Output Horizontal Tab Disposition"] dict set optioncodes 13 [list name "Output Formfeed Disposition"] dict set optioncodes 14 [list name "Output Vertical Tabstops"] dict set optioncodes 15 [list name "Output Vertical Tab Disposition"] dict set optioncodes 16 [list name "Output Linefeed Disposition"] dict set optioncodes 17 [list name "Extended Ascii"] dict set optioncodes 18 [list name "Logout"] dict set optioncodes 19 [list name "Byte Macro"] dict set optioncodes 20 [list name "Data Entry Terminal"] dict set optioncodes 21 [list name "SUPDUP"] dict set optioncodes 22 [list name "SUPDUP Output"] dict set optioncodes 23 [list name "Send Location"] dict set optioncodes 24 [list name "Terminal Type" short "ttype"] dict set optioncodes 25 [list name "End of Record"] dict set optioncodes 26 [list name "TACACS User Identification" short "tacacs"] dict set optioncodes 27 [list name "Output Marking"] dict set optioncodes 28 [list name "Terminal Location Number"] dict set optioncodes 29 [list name "Telnet 3270 Regime"] dict set optioncodes 30 [list name "X.3 PAD"] dict set optioncodes 31 [list name "Negotiate About Window Size" short "NAWS"] ;#RFC 1073 NAWS dict set optioncodes 32 [list name "Terminal Speed" short "tspeed"] ;#rfc 1079 dict set optioncodes 33 [list name "Remote Flow Control"] dict set optioncodes 34 [list name "Line Mode"] dict set optioncodes 35 [list name "X Display Location"] dict set optioncodes 36 [list name "Environment Option" short "env opt"] dict set optioncodes 37 [list name "Authentication Option" short "authent opt"] dict set optioncodes 38 [list name "Encryption Option" short "encrypt opt"] dict set optioncodes 39 [list name "New Environment Option" short "new env opt"] dict set optioncodes 40 [list name "TN3270E"] dict set optioncodes 41 [list name "XAUTH"] dict set optioncodes 42 [list name "CHARSET"] dict set optioncodes 43 [list name "Telnet Remote Serial Port (RSP)" short "RSP"] dict set optioncodes 44 [list name "Com Port Control Option"] dict set optioncodes 45 [list name "Telnet Supress Local Echo" short "no-local-echo"] dict set optioncodes 46 [list name "Telnet Start TLS" short "start_tls"] dict set optioncodes 47 [list name "KERMIT"] dict set optioncodes 48 [list name "SEND-URL"] dict set optioncodes 49 [list name "FORWARD_X"] #50-137 Unassigned #dict set optioncodes 70 [list name "?"] ;#trekmush dict set optioncodes 138 [list name "TELOPT PRAGMA LOGON"] dict set optioncodes 139 [list name "TELOPT SSPI LOGON"] dict set optioncodes 140 [list name "TELOPT PRAGMA HEARTBEAT"] #141-254 Unassigned #dict set optioncodes 201 [list name "?"] ;#trekmush dict set optioncodes 255 [list name "Extended-Options-List"] #we are assuming we initiated the connection, and are in some sense the 'client' variable server_option_state variable client_option_state variable client_option_declined #not all these will make sense as a boolean? review. #we use this also to support the Status option #this structure doesn't retain which side initiated - but it appears from the nature of the protocol that isn't always determinable or of importance. proc reset_option_states {} { variable optioncodes variable server_option_state variable client_option_state variable encoding_guess set encoding_guess utf-8 dict for {k _v} $optioncodes { dict set server_option_state $k 0 ;#DO from our perspective dict set client_option_state $k 0 ;#WILL from our perspective } variable client_option_declined ;#record explicit negative responses (won'ts) to DO requests from server set client_option_declined [dict create] } reset_option_states ;#initialise to NVT - all off proc get_server_option_state_summary {} { variable server_option_state variable optioncodes set summary "" dict for {k v} $server_option_state { if {$v} { if {[dict exists $optioncodes $k short]} { append summary "[dict get $optioncodes $k short]," } else { append summary "[dict get $optioncodes $k name]," } } } set summary [string trimright $summary ,] } proc get_client_option_state_summary {} { variable client_option_state variable optioncodes set summary "" dict for {k v} $client_option_state { if {$v} { if {[dict exists $optioncodes $k short]} { append summary "[dict get $optioncodes $k short]," } else { append summary "[dict get $optioncodes $k name]," } } } set summary [string trimright $summary ,] } proc get_client_option_declined_summary {} { variable client_option_declined variable optioncodes set summary "" dict for {k v} $client_option_declined { if {[dict exists $optioncodes $k]} { if {[dict exists $optioncodes $k short]} { append summary "[dict get $optioncodes $k short]," } else { append summary "[dict get $optioncodes $k name]," } } else { append summary "unknown option '$k'," } } set summary [string trimright $summary ,] } # ----------------------------------- # A rudimentary hardcoded configuration for options/negotiation # The way in which features are enabled/disabled and what goes together needs refinement & better understanding # todo - review #Note: further logic required, for example even something as supposedly simple as echo shouldn't be active on both ends at once or we get a loop. # Can't necessarily rely on other end not to allow us to do something insane. # Probably also.. some options should be under direct user ability to initiate/control - not just a configuration # For that to work fully we may need a separate punk::telnet package that has a pseudoterminal in front of the real console (scrolling sub-area), allowing a custom repl, custom status display etc. # We will keep punk::basictelnet as a simple interface using the real terminal - as a fallback for diagnosing oddities etc. # ----------------------------------- #Passively enabled server features - ie those we don't initiate but will accept #default response to WILL is WON'T #define our positive responses here for those that we will do variable respond_will_do set respond_will_do [list] lappend respond_will_do 0 ;#binary lappend respond_will_do 1 ;#echo lappend respond_will_do 3 ;#suppress go-ahead lappend respond_will_do 5 ;#status - by agreeing to this we should be able to read unsolicited "IAC SB STATUS IS ... IAC SE" reports and compare to our perception of state. (and do something if mismatches?) lappend respond_will_do 24 ;#remote is letting us know they are willing to send terminal-type - but we would still have to request it #passively enabled client features - requests for our own behaviours we will respond positively variable respond_do_will set respond_do_will [list] lappend respond_do_will 0 ;#binary lappend respond_do_will 3 ;#Suppress go-ahead lappend respond_do_will 5 ;#status - by agreeing to this - we need to handle the subnegotiation "IAC SB STATUS SEND IAC SE" and respond with "IAC SB STATUS IS ... IAC SE" lappend respond_do_will 24 ;#terminal-type lappend respond_do_will 31 ;#window size - for now we will just immediately respond to a server's DO 31 with our window size #ACTIVE server features - those we attempt to initiate regarding the server's behaviour variable initiate_do set initiate_do [list] variable initiate_will set initiate_will [list] # ----------------------------------- variable fromserver_unprocessed set fromserver_unprocessed "" variable in_sb ;#whether we are in subnegotiation parameters and waiting for SE e.g for STATUS we may get multiple or evan all other codes as a report of the other side's perception of the option states. set in_sb 0 variable sb_state [dict create] #proc sample1 {p1 n args} { # #*** !doctools # #[call [fun sample1] [arg p1] [arg n] [opt {option value...}]] # #[para]Description of sample1 # #[para] Arguments: # # [list_begin arguments] # # [arg_def tring p1] A description of string argument p1. # # [arg_def integer n] A description of integer argument n. # # [list_end] # return "ok" #} # --------------------- #window height/width proc int_to_2telnetbytes {int} { set binstr [format %16.16b $int] set a [string range $binstr 0 7] set b [string range $binstr 8 end] return [binary format B8B8 $a $b] } #double up \xff as per Telnet protocol. ie double the IAC byte to send as literal proc int_to_telnetbytes {int} { set out "" set 2bytes [int_to_2telnetbytes $int] foreach b [split $2bytes ""] { if {$b eq "\xFF"} { append out \xff\xff } else { append out $b } } return $out } proc sb_send_window_size {sock cols rows} { #IAC SB NAWS c1 c2 r1 r2 IAC SE - where c1 c2 are 2 bytes for cols, r1 r2 are 2 bytes for rows - (unless any of the bytes is \xFF in which case it's doubled-up as per telnet protocol) set c_bytes [int_to_telnetbytes $cols] ;#int_to_telnetbytes does the \xFF double-up if needed set r_bytes [int_to_telnetbytes $rows] puts -nonewline $sock \xff\xfa[binary format c 31]${c_bytes}${r_bytes}\xFF\xf0 } # --------------------- variable debug_buffer set debug_buffer "" variable writing_debug_frame 0 ;#re-entrancy protection #experiment proc debug_frame {info inputchannel outputchannel} { variable consolewidth variable encoding_guess variable terminal_type variable writing_debug_frame if {$writing_debug_frame == 1} { after 1 {punk::basictelnet::add_debug "" $readchannel $writechannel} return } variable debug variable can_debug ;#we'll only support debug if we can use the punk ansi frame mechanism #The frame mechanism isn't as good as a proper split-screen as it redraws on rhs and looks bad in scrollback - but it's better than putting debug output on lhs in with data if {!$can_debug || !$debug} {return} incr writing_debug_frame set server_summary "SVR-WILL:[a+ green][get_server_option_state_summary][a]" set client_summary "CLI-WILL:[a+ green][get_client_option_state_summary][a]" set client_declined "CLI-WONT:[a+ red bold][get_client_option_declined_summary][a]" set info $server_summary\n$client_summary\n$client_declined\n$info #set existing_handler [fileevent stdin readable] set RST "\x1b\[m" set debug_width 80 set infoframe [textblock::frame -width $debug_width -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug $terminal_type (encoding guess:$encoding_guess)$RST" $info] #set w [textblock::width $infoframe] set spacepatch "$RST[textblock::block $debug_width 4 { }]" #puts -nonewline [punk::ansi::cursor_off] #use non cursorsave version - slower - but less likely to interfere with cursor operations in data set existing_input_handler [fileevent $inputchannel readable] ;#stdin fileevent $inputchannel readable {} if {[string length $outputchannel]} { set existing_output_handler [fileevent $outputchannel readable] ;#sock fileevent $outputchannel readable {} } if {[catch { #90 set debug_offset [expr {$consolewidth - $debug_width}] punk::console::move_emitblock_return 6 $debug_offset $spacepatch flush stdout punk::console::move_emitblock_return 10 $debug_offset $infoframe flush stdout #puts -nonewline stdout [punk::ansi::cursor_on] ;#Enabling cursor should take account of whether it was enabled before - we don't have that info currently! review } errM]} { puts stderr "debug_frame error: $errM" } #todo - try? finally? set writing_debug_frame 0 fileevent $inputchannel readable $existing_input_handler if {[string length $outputchannel]} { fileevent $outputchannel readable $existing_output_handler } return } #inputchannel stdin, outputchannel sock proc add_debug {newlines inputchannel outputchannel} { variable debug variable can_debug variable debug_buffer if {!$can_debug} {return} append debug_buffer $newlines set lines [split $debug_buffer \n] set lines [lrange $lines end-40 end] set debug_buffer [join $lines \n] if {[string length $debug_buffer] && $debug} { debug_frame $debug_buffer $inputchannel $outputchannel } } proc telnet {{server localhost} {port telnet}} { variable debug variable consolewidth ;#note - this is not terminal width for the telnet output - which needs to be about 80cols narrower if debug is to be displayed on same screen set consolewidth [dict get [punk::console::get_size] columns] if {$debug && $consolewidth-$::punk::basictelnet::window_cols < 80} { puts stderr "Terminal width not wide enough for debug_window width: 80 + telnet window_cols:$::punk::basictelnet::window_cols" puts stderr "Turn off debug, or make terminal window wider" return } elseif {$consolewidth < $::punk::basictelnet::window_cols} { puts stderr "Terminal width is less than telnet window_cols:$::punk::basictelnet::window_cols" puts stderr "Ensure terminal is greater than or equal to punk::basictelnet::window_cols" return } #todo - allow telnet with channels other than stdin/stdout - and multiple sessions - per session option_states reset_option_states set sock [socket $server $port] #fconfigure $sock -buffering none -blocking 0 -encoding binary -translation crlf -eofchar {} #fconfigure $sock -buffering none -blocking 0 -encoding binary -translation binary -eofchar {} fconfigure $sock -buffering none -blocking 0 -encoding iso8859-1 -translation binary -eofchar {} fconfigure stdout -buffering none fileevent $sock readable [list [namespace current]::fromServer $sock] chan configure stdin -blocking 0 fileevent stdin readable [list [namespace current]::toServer $sock] variable closed vwait ::punk::basictelnet::closed($sock) unset closed($sock) chan conf stdin -blocking 1 } #specifically named 'waiting' argument as last argument for cooperative input reading with other punk channel handlers (repl in particular) #waiting data will be supplied to this handler if the other handler over-read (e.g repl handling ANSI ESC \[6n response on stdin finding other data before the ANSI response.) proc toServer {sock} { variable server_option_state variable encoding_guess #note that this punk::console namespace is likely to be in a different thread (codethread) to the punk::repl thread which will have it's own punk::console namespace # - even though they may both be using the same stdin stdout. The repl readloop will be inactive during the call to telnet upvar ::punk::console::input_chunks_waiting input_chunks_waiting set nextwaiting "" if {[info exists input_chunks_waiting(stdin)] && [llength $input_chunks_waiting(stdin)]} { set nextwaiting [lindex $input_chunks_waiting(stdin) 0] set input_chunks_waiting(stdin) [lrange $input_chunks_waiting(stdin) 1 end] } fileevent stdin readable {} if {$nextwaiting eq ""} { set chunk [read stdin] } else { set chunk $nextwaiting } if {[string length $chunk] >= 0} { # - this mechanism is a heuristic rather than a proper determination of the situation. review if {[string first \r $chunk] >=0} { #assuming terminal newline is (usual case in raw mode) if {[string first \r\n $chunk] < 0} { #only map it if we don't already see \r\n present set chunk [string map [list \r \r\n ] $chunk] } } else { #presuming cooked mode set chunk [string map [list \n \r\n] $chunk] } # - review #if we didn't make agreement that server would echo and we're in raw mode if {![dict get $server_option_state 1] && $::punk::console::is_raw} { puts -nonewline stdout $chunk } # -- --- --- --- set tailinfo "" if {[string length $nextwaiting]} { set waitingdisplay [overtype::renderspace -cp437 1 -wrap 1 -width 77 -height 1 "" [ansistring VIEW -lf 1 -vt 1 $nextwaiting]] set tailinfo "[a+ red]from waiting:\n $waitingdisplay[a]" } ::punk::basictelnet::add_debug "[a+ Yellow black]from stdin sending: [ansistring VIEW -lf 1 -vt 1 $chunk][a]\n$tailinfo\n" stdin $sock # -- --- --- --- if {[catch { puts -nonewline $sock $chunk flush $sock set wrote_sock 1 } errM]} { puts stderr "Failed to write to socket $socket: data: [ansistring VIEW -lf 1 $chunk]" set wrote_sock 0 } if {$wrote_sock && ![eof $sock]} { ################################################################################## #Re-enable channel read handler only if no waiting chunks - must process in order ################################################################################## if {![llength $input_chunks_waiting(stdin)]} { fileevent stdin readable [list [namespace current]::toServer $sock] } else { #after idle [list [namespace current]::toServer $sock] tailcall [namespace current]::toServer $sock } #################################################### #fileevent stdin readable [list [namespace current]::toServer $sock] } else { disconnect sock } } else { disconnect $sock } } proc toServer1 {sock} { if {[gets stdin line] >= 0} { puts -nonewline $sock $line\r\n } else { disconnect $sock } } proc fromServer {sock} { variable encoding_guess variable debug variable fromserver_unprocessed fileevent $sock readable {} variable in_sb set chunksize 4096 ;#No choice of chunksize can avoid the possibility of splitting a token such as a Telnet protocol command or an ANSI sequence. #in theory, a split ANSI sequence won't cause a problem - except if we have debug on which could emit a request on stdout (e.g get_cursor_pos) #as a byte oriented supposedly ascii-by-default protocol - we shouldn't expect to get utf-8 without having negotiated it - but it looks suspiciously like this is the sort of thing that happens (2024) review? Examples? mapscii.me 1984.ws? Test. #randomly chosen chunk boundaries - whether due to size or a combination of network speed and event scheduling can mean we get some utf8 characters split too. set last_unprocessed $fromserver_unprocessed set data $fromserver_unprocessed set fromserver_unprocessed "" append data [read $sock $chunksize] #repeatedly appending when not fblocked - will somewhat reduce the risk of splitting both ANSI and TELNET commands - but at the cost of starving the output processing #somewhat conveniently? - the IAC \xFF byte is not valid in utf-8 or ascii #this whole mechanism may need to be reviewed/modified if/when Telnet binary mode and/or charset changing is implemented/understood by the author. #The current basic system is tested on the few available public telnet servers. - todo - test on some old industrial equipment, read more RFCs. #for now we'll use punk::lib::get_utf8_leading as a hack way to determine if we should throw some trailing data aside for next loop to process? #while {![fblocked $sock] && ![eof $sock]} { # add_debug "[a+ red bold]RE-READ[a]\n" stdin $sock # append data [read $sock $chunksize] #} if {[eof $sock]} { add_debug "[a+ red]socket eof[a]\n" stdin $sock disconnect $sock return } if {![string length $data]} { puts stderr "telnet: 0 length read on sock $sock" set data [read $sock] if {[eof $sock]} { add_debug "[a+ red]socket eof after final read attempt[a]\n" stdin $sock disconnect $sock return } elseif {[string length $data] == 0} { add_debug "[a+ red]socket 2nd empty read[a]\n" stdin $sock disconnect $sock return } } #mini debug buffer for each fromServer call - render using add_debug each loop set debug_info "" if {$debug} { #only do this text-processing work if debug is on append debug_info "------raw data [string length $data]---prev unprocessed:[string length $last_unprocessed]---" \n #append debug_info [ansistring VIEW -lf 1 -vt 1 [encoding convertfrom utf-8 $data]] \n #set rawview [ansistring VIEW -lf 1 -vt 1 [encoding convertfrom $encoding_guess $data]] set rawview [ansistring VIEW -lf 1 -vt 1 $data] #set viewblock [overtype::left -wrap 1 -width 78 -height 4 "" $rawview] set viewblock [overtype::renderspace -cp437 1 -wrap 1 -width 78 -height 4 "" $rawview] set lines [split $viewblock \n] if {[llength $lines] > 4} { append debug_info [join [list {*}[lrange $lines 0 1] "...<[expr {[llength $lines] -4}] lines undisplayed>..." {*}[lrange $lines end-1 end]] \n] } else { append debug_info $viewblock } append debug_info "\n------------------------------------------" \n } if {[string length $data]} { #puts "1----------------------------------" #puts [ansistring VIEW -lf 1 -vt 1 $data] #--------------- #TODO - fix possible chunk boundary that gives us an incomplete IAC sequence. #As it stands - we won't properly handle it - possible it will cause intermittent telnet protocol bugs! #will need a mechanism within protocol function and loop to abort and throw back to next fromServer event #--------------- while 1 { if {!$in_sb} { #\xff 255 is the IAC Data Byte (Interpret As Command) set idx [string first \xff $data] if {$idx < 0} { append debug_info "[a+ green][a]" \n if {[string length $data] == 1} { append debug_info "SINGLE CHAR: [scan $data %c]" \n } #jmn break } #write [string range $data 0 $idx-1] puts -nonewline stdout [encoding convertfrom $encoding_guess [string range $data 0 $idx-1]] flush stdout set post_IAC_byte [string index $data [expr {$idx+1}]] if {$post_IAC_byte < "\xef"} { #?? #write \xf0$post_IAC_byte ;#from wiki code. purpose not understood. puts stderr "unexpected - byte less than EF following IAC" set data [string range $data $idx+1 end] incr idx } elseif {$post_IAC_byte == "\xff"} { #write \xf0 ;#?? This came from wiki code - intention unclear.. latin small letter Eth #RFC indicates double up of \xff is treated as literal #this can't be part of utf-8 - puts -nonewline stdout \xff set data [string range $data $idx+2 end] incr idx 2 } else { incr idx 2 set ophex "" #telnet commands are at least 2 bytes binary scan $post_IAC_byte H2 cmdhex switch -- $cmdhex { fb - fc - fd - fe { #WILL, WON'T, DO, DON'T #3bytes - last is option set opbyte [string index $data $idx] #don't incr idx - protocol will do so #incr idx binary scan $opbyte H2 ophex } fa { #SB #3 bytes + #better handled in protocol - set flag to indicate next data expected is optiondata + IAC SE ? #SB - ended by IAC SE (\xff \xf0) set sb_posn [string first \xff\xf0 $data] #no guarantee our read-chunk didn't split before corresponding SE! #but then.. no guarantee our loop doesn't split after IAC either - need fromserver loop redesign to allow requeuing data? if {$sb_posn < 0} { puts stderr "SB missing terminating SE - loop programming incomplete - TODO" } else { } set opbyte [string index $data [expr {$idx}]] binary scan $opbyte H2 ophex } default { } } protocol $sock $cmdhex $ophex set data [string range $data $idx end] } } else { #in_sb #can we get carriage-returns mixed in? seems possible.. set byte [string index $data 0] binary scan $byte H2 bytehex #byte may be IAC or cmd such as DO,WILL etc (e.g for status cmd it will list bytes as something like DO opt1 WILL opt2 before trailing IAC SE) switch -- $bytehex { ff { #expecting SE next - but will pass to protocol as if it's the 'cmd' for handling/verification set expectedSE [string index $data 1] binary scan $expectedSE H2 expectedSEhex protocol $sock $expectedSEhex "" } default { set opbyte [string index $data 1] binary scan $opbyte H2 ophex protocol $sock $bytehex $ophex } } #JMN? set data [string range $data $idx end] } } ;#end inner while if {$encoding_guess eq "utf-8"} { set prefix [punk::lib::get_utf8_leading $data] set plen [string length $prefix] set tail [string range $data $plen end] if {[string length $tail] && [string index $tail 0] ne "\xFF" && ![punk::lib::is_utf8_multibyteprefix $tail]} { puts stderr ">>>>[ansistring VIEW -lf 1 -vt 1 $tail]<<<<" #Our utf-8 guess has been disproven! set encoding_guess cp437 set prefix $data set tail "" } } else { set prefix $data set tail "" } set ansisplits [list] if {[string length $tail]} { set fromserver_unprocessed $tail puts -nonewline stdout [encoding convertfrom $encoding_guess $prefix] } else { set fromserver_unprocessed "" #look for incomplete ansi sequences #REVIEW - encoding ? set ansisplits [punk::ansi::ta::split_codes_single $prefix] set last_pt [lindex $ansisplits end] ;#last part is supposed to be plaintext - if it looks like it contains a partial ansi - throw it to fromserver_unprocessed for next fromServer call if {[string first "\x1b" $last_pt] >= 0} { set complete [join [lrange $ansisplits 0 end-1] ""] puts -nonewline stdout [encoding convertfrom $encoding_guess $complete] set fromserver_unprocessed $last_pt } else { puts -nonewline stdout [encoding convertfrom $encoding_guess $prefix] } } flush stdout set data "" } ;#end outer while punk::basictelnet::add_debug $debug_info stdin $sock set debug_info "" #add_debug has potentially written to another part of the screen with different SGR colour/background etc #ie - by interrupting the telnet data with our own output, we lose SGR context when returning to normal output. if {$debug} { if {![llength $ansisplits]} { set ansisplits [punk::ansi::ta::split_codes_single $prefix] } #we haven't been tracking the ansicode stack - for now we'll just replay the last set of SGR codes received in this chunk - may not always work! #the effect we generally get by not doing these replays are unstyled characters in the output - presumably whenever we have jumped to debug output #todo - consider impact of full tracking of ansi SGR stack on stream.. (only when in debug?) set sgrstack [list] foreach {pt ansicode} $ansisplits { if {$ansicode ne ""} { if {[punk::ansi::codetype::is_sgr $ansicode]} { lappend sgrstack $ansicode } } } if {[llength $sgrstack]} { #replay the SGR stack (only goes back within current chunk - often all that's needed - but not ideal) puts -nonewline stdout [punk::ansi::codetype::sgr_merge_list {*}$sgrstack] flush stdout } } #after idle [list fileevent $sock readable [list [namespace current]::fromServer $sock]] if {[string length $fromserver_unprocessed]} { #review - by throwing to another loop without waiting for readable event - we could spin on same data...? #after idle [list [namespace current]::fromServer $sock] fileevent $sock readable [list [namespace current]::fromServer $sock] } else { fileevent $sock readable [list [namespace current]::fromServer $sock] } } proc disconnect {sock} { variable closed puts stdout "local disconnect" catch {fileevent $sock readable {}} catch {close $sock} set closed($sock) 1 fileevent stdin readable {} } proc write string { puts -nonewline stdout "write:'[ansistring VIEW [encoding convertfrom iso8859-1 $string]]'" #puts -nonewline stdout [encoding convertfrom utf-8 $string] } variable cmdmap set cmdmap [dict create\ ef [list name EOR code 239 meaning "End-of-Record"]\ f0 [list name SE code 240 meaning "End of subnegotiation parameters"]\ f1 [list name NOP code 241 meaning "no-op"]\ f2 [list name "Data Mark" code 242 meaning "The data stream portion of a Synch"]\ f3 [list name "Break" code 243 meaning "NVT character BRK"]\ f4 [list name "Interrupt Process" code 244 meaning "The function IP"]\ f5 [list name "Abort Output" code 245 meaning "The function AO"]\ f6 [list name "Are You There" code 246 meaning "The function AYT"]\ f7 [list name "Erase Character" code 247 meaning "The function EC"]\ f8 [list name "Erase Line" code 248 meaning "The function EL"]\ f9 [list name "Go Ahead" code 249 meaning "The GA signal"]\ fa [list name "SB" code 250 meaning "Indicates that what follows is subnegotiation of the indicated option"]\ fb [list name "WILL" code 251 meaning "Indicates the desire to begin performing, or confimation that you are now performing, the indicated option"]\ fc [list name "WON'T" code 252 meaning "Indicates the refusal to peform or continue performing, the indicated option"]\ fd [list name "DO" code 253 meaning "Indicates the request that the other party perform, or confirmation that you are expecting the other party to perform, the indicated option"]\ fe [list name "DON'T" code 254 meaning "Indicates the demand that the other party stop performaing, or confirmation that you are no longer expecting the other party to perform, the indicated option"]\ ] proc cmd_info {cmd} { variable cmdmap #ef - extension to rfc-854 if {[dict exists $cmdmap $cmd]} { return [dict get $cmdmap $cmd] } else { #return "unknown cmd :$cmd" return [dict create name "UNKNOWN" code [scan $cmd %x] meaning "UNKNOWN-$cmd"] } } proc protocol {sock cmdhex ophex} { variable in_sb variable sb_state variable optioncodes variable respond_will_do variable respond_do_will variable client_option_state ;#WILLs variable client_option_declined ;#WON'Ts - but only those that were actually requested by server - not our default won'ts variable server_option_state ;#DOs upvar 1 debug_info debug_info upvar 1 data data idx idx set opdec "" if {$ophex ne ""} { set opdec [scan $ophex %x] } flush stderr if {!$in_sb} { #append debug_info "cmdhex:$cmdhex [cmd_info $cmdhex]" \n append debug_info "[dict get [cmd_info $cmdhex] name]" if {[dict exists $optioncodes $opdec]} { append debug_info " option:$opdec [dict get $optioncodes $opdec]" \n } else { append debug_info " unrecognised option: $opdec" \n } flush stderr switch $cmdhex { f0 {# SE - End of subnegoatiation parameters 240 #error to get when not in sb? puts stderr "Unexpected SE. We don't appear to be in SB!" flush stderr } f1 {# NOP 241 return } f2 {# DATA MARK 242 } f3 {# BRK 243 } f4 {# IP - Interrupt Process 244 } f5 {# AO - Abort Output 245 } f6 {# AYT - Are you there 246 #return something screen visible append debug_info { replying to AYT: [YES] } \n puts $sock {[YES]} flush $sock } f7 {# EC - Erase Character 247 write \u007f } f8 {# EL - Erase Line 248 write \u0019 } f9 {# GA - Go Ahead 249 append debug_info ">>> Received Go Ahead <<<" \n } fa {# SB - Subnegotiation 250 # Should search forward for IAC SE (\xff\xf0) - or use in_sb to keep reading set in_sb 1 if {[dict get $client_option_state $opdec] || [dict get $server_option_state $opdec]} { incr idx #action for many subnegotiations is SEND=1 or IS=0 set actionbyte [string index $data $idx] set actiondec [scan $actionbyte %c] incr idx ;#for action switch -- $opdec { 5 { #status switch -- $actiondec { 0 { #IS #we should only get these reports if status is in our DO list #keep in_sb as 1 and initialise sb_state dict set sb_state opdec $opdec dict set sb_state actiondec 0 dict set sb_state data [dict create] } 1 { #SEND #we should only get a request to send status if it is in our WILL list #expect the IAC SE to immediately follow if {[string range $data $idx $idx+1] ne "\xff\xf0"} { error "malformed send status request" } incr idx 2 if {![dict get $client_option_state $opdec]} { #ignore puts stderr "Warning received status request - but it is not in our WILL list" } else { #build a list of WILLs and DOs and reply with status report #e.g (no linebreaks/spaces implied) #IAC SB STATUS IS #WILL ECHO #DO SUPPRESS-GO-AHEAD #WILL STATUS #DO STATUS #IAC SE set report \xff\xfa\x05\x00 ;#IAC SB STATUS IS dict for {optdec state} $client_option_state { if {$state} { append report \xfb[format %c $optdec] ;#WILL } } dict for {optdec state} $server_option_state { if {$state} { append report \xfd[format %c $optdec] ;#DO } } append report \xff\xf0 ;#IAC SE append debug_info "[a+ yellow bold]Sent status report[a]" \n #puts -nonewline $sock $report\r\n ;#newline or not? puts -nonewline $sock $report flush $sock } #The received subnegotiation is over set in_sb 0 } default { #unknown/unsupported } } } 24 { #terminal-type switch -- $actiondec { 0 { #IS #we should only get these reports if status is in our DO list #as maximum set nextSE [string first \xff\xf0 $data] if {$nextSE > 0} { set remote_terminal_type [string range $data $idx $nextSE-1] set idx [expr {$nextSE+2}] } else { #could presumably happen.. todo error "didn't receive terminal-type in single chunk - review code" } ##keep in_sb as 1 and initialise sb_state #dict set sb_state opdec $opdec #dict set sb_state actiondec 0 #dict set sb_state data [dict create] } 1 { #SEND #we should only get a request to send status if it is in our WILL list #expect the IAC SE to immediately follow if {[string range $data $idx $idx+1] ne "\xff\xf0"} { error "malformed send status request" } incr idx 2 if {![dict get $client_option_state $opdec]} { #ignore puts stderr "Warning received terminal-type SB request - but it is not in our WILL list" } else { variable terminal_type set report \xff\xfa\x18\x00 ;#IAC SB TERMINAL-TYPE IS append report $terminal_type append report \xff\xf0 ;#IAC SE #debug append debug_info "[a+ green bold]Sent terminal-type [ansistring VIEW $report\r\n][a]" \n #puts -nonewline $sock $report\r\n ;#newline or not? puts -nonewline $sock $report flush $sock } #The received subnegotiation is over set in_sb 0 } } } default { #if we've responded positively to supporting the option - it should have a switch-arm here error "No switch handler for option '$opdec' [dict get $optioncodes $opdec]" } } } else { #an attempt to subnegotiate an item we haven't agreed upon? puts stderr "Bad SB subnegotiation for operation [dict get $optioncodes $opdec] - not in our WILL list!" #todo - ignore? #we shouldn't get here if we are properly in sync with a well-behaved partner #if we do however.. we need to either abort immediately.. or ignore the subnegotiation by skipping ahead to SE as it may not even be an SB structure we understand. #let's try the ignore option first.. set next_SE [string first \xff\xf0 $data] if {$next_SE >=0} { set idx [expr {$next_SE +2}] set in_sb 0 } else { #unrecoverable? error "Unable to find ending SE for bad SB!" } } } fb {# WILL - 251 variable respond_will_do set byte [string index $data $idx] if {$opdec in $respond_will_do} { if {[dict get $server_option_state $opdec]} { #already known DO } else { append debug_info ">>>responding to server WILL declaration. DO $opdec [dict get $optioncodes $opdec]<<<" \n puts -nonewline $sock \xff\xfd$byte ;#respond DO dict set server_option_state $opdec 1 } } else { # Attempt to negotiate; refuse! puts -nonewline $sock \xff\xfe$byte ;#respond DON'T } flush $sock incr idx } fc {# WON'T - 252 #todo dict set server_option_state $opdec 0 incr idx } fd {# DO - 253 variable respond_do_will set byte [string index $data $idx] if {$opdec in $respond_do_will} { if {[dict get $client_option_state $opdec]} { #already stored WILL } else { append debug_info ">>>responding to server DO request. WILL $opdec [dict get $optioncodes $opdec]" \n puts -nonewline $sock \xff\xfb$byte ;#respond WILL dict set client_option_state $opdec 1 #immediate followup for NAWS (negotiate about window size) flush $sock if {$opdec == 31} { #IAC SB NAWS c1 c2 r1 r2 IAC SE - where c1 c2 are 2 bytes for cols, r1 r2 are 2 bytes for rows - (unless any of the bytes is \xFF in which case it's doubled-up as per telnet protocol) append debug_info ">>> sending window_size $::punk::basictelnet::window_cols $::punk::basictelnet::window_rows <<<\n" sb_send_window_size $sock $::punk::basictelnet::window_cols $::punk::basictelnet::window_rows } } } else { # Attempt to negotiate; refuse! dict set client_option_declined $opdec 1 ;#for now just store 1 - we could store a reason/timestamp? list? puts -nonewline $sock \xff\xfc$byte } flush $sock incr idx } fe {# DON'T - 254 set byte [string index $data $idx] if {[dict exists $client_option_state $opdec]} { if {![dict get $client_option_state $opdec]} { #already off } else { append debug_info ">>>responding to server DON'T request. WON'T $opdec [dict get $optioncodes $opdec]" \n dict set client_option_state $opdec 0 puts -nonewline $sock \xff\xfc$byte flush $sock } } else { #we don't even know that opdec } incr idx } } } else { #in_sb set state_opdec [dict get $sb_state opdec] if {$cmdhex eq "\xf0"} { #this indicates an IAC SE sequence was received #finished SB - do something with the gathered data switch -- $state_opdec { 5 { set reported_state [dict get $sb_state data] #todo - compare our stored state with the report #we assume report has all the will and do entries - so we enumerate the server_option_state and client_option_state entries to make sure we notice if there are extras #these are DO from our perspective - but reported as WILL from perspective of the other end set mismatches [list] dict for {opt state} $server_option_state { if {$state} { if {![dict exists $reported_state will $opt]} { lappend mismatches [list server $opt reported DON'T stored DO] } } else { if {[dict exists $reported_state will $opt]} { lappend mismatches [list server $opt reported DO stored DON'T] } } } #these are WILL from our perspective - but reported as DO from perspective of the other end dict for {opt state} $client_option_state { if {$state} { if {![dict exists $reported_state do $opt]} { lappend mismatches [list client $opt reported WON'T stored WILL] } } else { if {[dict exists $reported_state do $opt]} { lappend mismatches [list client $opt reported WILL stored WON'T] } } } if {[llength $mismatches]} { puts stderr "Apparent mismatch in stored DO/WILL vs status report from server" puts stderr "$mismatches" #todo - what? } else { append debug_info "Server status report matches stored values" \n } } } set in_sb 0 set sb_state [dict create] } else { #in progress - some subelement of the SB switch -- $state_opdec { 5 { #only supported in_sb action is 0 - read the status report from the other side append debug_info "Got status report element [cmd_info $cmdhex]" \n set existing_data [dict get $sb_state data] ;#data is specific to each type of subnegotiation set opdec [scan $ophex %x] switch -- $cmdhex { fb { dict set existing_data will $opdec 1 } fd { dict set existing_data do $opdec 1 } } dict set sb_state data $existing_data ;#updated } } } } } interp alias "" tnet1 "" punk::basictelnet::telnet #*** !doctools #[list_end] [comment {--- end definitions namespace punk::basictelnet ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # Secondary API namespace # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ namespace eval punk::basictelnet::lib { namespace export * namespace path [namespace parent] #*** !doctools #[subsection {Namespace punk::basictelnet::lib}] #[para] Secondary functions that are part of the API #[list_begin definitions] #proc utility1 {p1 args} { # #*** !doctools # #[call lib::[fun utility1] [arg p1] [opt {?option value...?}]] # #[para]Description of utility1 # return 1 #} #*** !doctools #[list_end] [comment {--- end definitions namespace punk::basictelnet::lib ---}] } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ #*** !doctools #[section Internal] namespace eval punk::basictelnet::system { #*** !doctools #[subsection {Namespace punk::basictelnet::system}] #[para] Internal functions that are not part of the API } # ++ +++ +++ +++ +++ +++ +++ +++ +++ +++ +++ ## Ready package provide punk::basictelnet [namespace eval punk::basictelnet { variable pkg punk::basictelnet variable version set version 999999.0a1.0 }] return #*** !doctools #[manpage_end]