6 changed files with 1054 additions and 24 deletions
@ -0,0 +1,933 @@ |
|||||||
|
# -*- tcl -*- |
||||||
|
# Maintenance Instruction: leave the 999999.xxx.x as is and use punkshell 'pmix make' or bin/punkmake to update from <pkg>-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 <unspecified> |
||||||
|
# @@ 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 * |
||||||
|
|
||||||
|
#todo - use these as defaults - provide a way to configure/listen to local events and notify server |
||||||
|
set window_cols 80 |
||||||
|
set window_rows 25 |
||||||
|
|
||||||
|
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 |
||||||
|
variable remote_terminal_type |
||||||
|
set remote_terminal_type "" ;#emtpy 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"] |
||||||
|
dict set optioncodes 1 [list name "Echo"] |
||||||
|
dict set optioncodes 2 [list name "Reconnection"] |
||||||
|
dict set optioncodes 3 [list name "Suppress Go Ahead"] |
||||||
|
dict set optioncodes 4 [list name "Approx Message Size Negotiation"] |
||||||
|
dict set optioncodes 5 [list name "Status"] ;#RFC 859 |
||||||
|
dict set optioncodes 6 [list name "Timing Mark"] |
||||||
|
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"] |
||||||
|
dict set optioncodes 25 [list name "End of Record"] |
||||||
|
dict set optioncodes 26 [list name "TACACS User Identification"] |
||||||
|
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"] ;#RFC 1073 NAWS |
||||||
|
dict set optioncodes 32 [list name "Terminal Speed"] ;#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"] |
||||||
|
dict set optioncodes 37 [list name "Authentication Option"] |
||||||
|
dict set optioncodes 38 [list name "Encryption Option"] |
||||||
|
dict set optioncodes 39 [list name "New Environment Option"] |
||||||
|
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)"] |
||||||
|
dict set optioncodes 44 [list name "Com Port Control Option"] |
||||||
|
dict set optioncodes 45 [list name "Telnet Supress Local Echo"] |
||||||
|
dict set optioncodes 46 [list name "Telnet 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 |
||||||
|
#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. |
||||||
|
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 |
||||||
|
} |
||||||
|
|
||||||
|
# ----------------------------------- |
||||||
|
# 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 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} { |
||||||
|
variable writing_debug_frame |
||||||
|
if {$writing_debug_frame > 1} { |
||||||
|
if {$writing_debug_frame >= 3} { |
||||||
|
puts stderr "Warning - writing_debug_frame=$writing_debug_frame" |
||||||
|
} |
||||||
|
return |
||||||
|
} elseif {$writing_debug_frame == 1} { |
||||||
|
incr writing_debug_frame |
||||||
|
after 1 {punk::basictelnet::add_debug ""} |
||||||
|
return |
||||||
|
} |
||||||
|
incr writing_debug_frame |
||||||
|
|
||||||
|
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} |
||||||
|
|
||||||
|
set infoframe [textblock::frame -width 80 -ansiborder [a+ green bold] -title "[a cyan]Telnet Debug[a]" $info] |
||||||
|
set w [textblock::width $infoframe] |
||||||
|
set spacepatch [textblock::block $w 4 " "] |
||||||
|
puts -nonewline [punk::ansi::cursor_off] |
||||||
|
#use non cursorsave version - slower - but less likely to interfere with cursor operations in data |
||||||
|
|
||||||
|
#punk::console::move_emitblock_return 6 90 $spacepatch\n$infoframe |
||||||
|
punk::console::move_emitblock_return 6 90 $spacepatch |
||||||
|
punk::console::move_emitblock_return 10 90 $infoframe |
||||||
|
puts -nonewline [punk::ansi::cursor_on] |
||||||
|
#todo - try? finally? |
||||||
|
set writing_debug_frame 0 |
||||||
|
return |
||||||
|
} |
||||||
|
|
||||||
|
proc add_debug {newlines} { |
||||||
|
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 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc telnet {{server localhost} {port telnet}} { |
||||||
|
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 stdout -buffering none |
||||||
|
#fileevent $sock readable [list initEvents $sock] |
||||||
|
fileevent $sock readable [list [namespace current]::fromServer $sock] |
||||||
|
chan configure stdin -blocking 0 |
||||||
|
fileevent stdin readable [list [namespace current]::toServer $sock] |
||||||
|
global closed |
||||||
|
vwait closed($sock) |
||||||
|
unset closed($sock) |
||||||
|
chan conf stdin -blocking 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc initEvents {sock} { |
||||||
|
puts -nonewline [read $sock 4096] |
||||||
|
fileevent $sock readable [list [namespace current]::fromServer $sock] |
||||||
|
fileevent stdin readable [list [namespace current]::toServer $sock] |
||||||
|
} |
||||||
|
|
||||||
|
#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 {waiting ""}} { |
||||||
|
set line $waiting |
||||||
|
if {[string length [append line [read stdin]]] >= 0} { |
||||||
|
|
||||||
|
# - this mechanism is a heuristic rather than a proper determination of the situation. review |
||||||
|
if {[string first \r $line] >=0} { |
||||||
|
#assuming terminal newline is <CR> (usual case in raw mode) |
||||||
|
if {[string first \r\n $line] < 0} { |
||||||
|
#only map it if we don't already see \r\n present |
||||||
|
set line [string map [list \r \r\n ] $line] |
||||||
|
} |
||||||
|
} else { |
||||||
|
#presuming cooked mode |
||||||
|
set line [string map [list \n \r\n] $line] |
||||||
|
} |
||||||
|
# - review |
||||||
|
|
||||||
|
after 1 [::punk::basictelnet::add_debug "[a+ Yellow black]from stdin sending: [ansistring VIEW -lf 1 -vt 1 $line][a]\n"] |
||||||
|
puts -nonewline $sock $line |
||||||
|
flush $sock |
||||||
|
update idletasks |
||||||
|
} else { |
||||||
|
disconnect $sock |
||||||
|
} |
||||||
|
} |
||||||
|
proc toServer1 {sock} { |
||||||
|
if {[gets stdin line] >= 0} { |
||||||
|
puts -nonewline $sock $line\r\n |
||||||
|
} else { |
||||||
|
disconnect $sock |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc fromServer {sock} { |
||||||
|
variable in_sb |
||||||
|
set data x |
||||||
|
while {[string length $data]} { |
||||||
|
if {[catch { |
||||||
|
set data [read $sock 4096] |
||||||
|
} errM]} { |
||||||
|
catch {disconnect $sock} |
||||||
|
add_debug "[a+ red]socket read fail: $errM[a]\n" |
||||||
|
return |
||||||
|
} |
||||||
|
if {[eof $sock]} { |
||||||
|
disconnect $sock |
||||||
|
return |
||||||
|
} |
||||||
|
#puts "1----------------------------------" |
||||||
|
#puts [ansistring VIEW -lf 1 -vt 1 $data] |
||||||
|
|
||||||
|
#mini debug buffer for each fromServer call - render using add_debug each loop |
||||||
|
set debug_info "" |
||||||
|
append debug_info "------raw data----------------------------" \n |
||||||
|
append debug_info [ansistring VIEW -lf 1 -vt 1 [encoding convertfrom utf-8 $data]] \n |
||||||
|
append debug_info "------------------------------------------" \n |
||||||
|
|
||||||
|
if {[string length $data]} { |
||||||
|
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]<response has no telnet commands string length data:[string length $data]>[a]" \n |
||||||
|
if {[string length $data] == 1} { |
||||||
|
append debug_info "SINGLE CHAR: [scan $data %c]" \n |
||||||
|
} |
||||||
|
after 1 [punk::basictelnet::add_debug $debug_info] |
||||||
|
set debug_info "" |
||||||
|
break |
||||||
|
} |
||||||
|
#write [string range $data 0 $idx-1] |
||||||
|
puts -nonewline stdout [encoding convertfrom utf-8 [string range $data 0 $idx-1]] |
||||||
|
set byte [string index $data [expr {$idx+1}]] |
||||||
|
incr idx 2 |
||||||
|
if {$byte < "\xef"} { |
||||||
|
#?? |
||||||
|
write \xf0$byte |
||||||
|
set data [string range $data $idx end] |
||||||
|
} elseif {$byte == "\xff"} { |
||||||
|
#?? |
||||||
|
write \xf0 |
||||||
|
set data [string range $data $idx end] |
||||||
|
} else { |
||||||
|
set ophex "" |
||||||
|
#telnet commands are at least 2 bytes |
||||||
|
binary scan $byte H2 cmdhex |
||||||
|
switch -- $cmdhex { |
||||||
|
fb - fc - fd - fe { |
||||||
|
#WILL, WON'T, DO, DON'T |
||||||
|
#3bytes - last is option |
||||||
|
set opbyte [string index $data [expr {$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 |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
#puts -nonewline stdout $data |
||||||
|
puts -nonewline stdout "[encoding convertfrom utf-8 $data]" |
||||||
|
} |
||||||
|
} |
||||||
|
} |
||||||
|
|
||||||
|
proc disconnect {sock} { |
||||||
|
global closed |
||||||
|
close $sock |
||||||
|
set closed($sock) 1 |
||||||
|
} |
||||||
|
|
||||||
|
proc write string { |
||||||
|
puts -nonewline stdout "write:'[ansistring VIEW [encoding convertfrom iso8859-1 $string]]'" |
||||||
|
#puts -nonewline stdout [encoding convertfrom utf-8 $string] |
||||||
|
} |
||||||
|
proc cmd_info {cmd} { |
||||||
|
#ef - extension to rfc-854 |
||||||
|
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"]\ |
||||||
|
] |
||||||
|
if {[dict exists $cmdmap $cmd]} { |
||||||
|
return [dict get $cmdmap $cmd] |
||||||
|
} else { |
||||||
|
return "unknown cmd :$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 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 |
||||||
|
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 |
||||||
|
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 "Sent status report" \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 "Sent terminal-type [ansistring VIEW $report\r\n]" \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 { |
||||||
|
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 |
||||||
|
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 DO. 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" |
||||||
|
sb_send_window_size $sock $::punk::basictelnet::window_cols $::punk::basictelnet::window_rows |
||||||
|
} |
||||||
|
} |
||||||
|
} else { |
||||||
|
# Attempt to negotiate; refuse! |
||||||
|
puts -nonewline $sock \xff\xfc$byte |
||||||
|
} |
||||||
|
flush $sock |
||||||
|
incr idx |
||||||
|
} |
||||||
|
fe {# DON'T - 254 |
||||||
|
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] |
||||||
|
|
||||||
@ -0,0 +1,3 @@ |
|||||||
|
0.1.0 |
||||||
|
#First line must be a semantic version number |
||||||
|
#all other lines are ignored. |
||||||
Loading…
Reference in new issue