#!/usr/local/bin/tcl
#
# Copyright 1993, John Robert LoVerso
#
# Permission to use, copy, modify, and distribute this software and its
# documentation for any purpose and without fee is hereby granted, provided
# that the above copyright notice appear in all copies.  The author makes
# no representations about the suitability of this software for any purpose.
# It is provided "as is" without express or implied warranty.
#
# $Id: tcltelnet,v 1.21 1994/03/30 18:53:16 loverso Exp loverso $
#

if 0 {
Message-ID: <06Aug93.133200@LoVerso.Southborough.MA.US>
From: John Robert LoVerso <John@LoVerso.Southborough.MA.US>
Organization: John & Sue's House, Southborough MA
Subject: toy telnet client in tcl

This is a toy telnet client I tossed together.  It is only the second
thing I've writtn in tcl.  It requires tcl7.0 and tclX7.0.

This contains a reasonably simple implementation of telnet option processing.
Basically, it knows to enable char-at-a-time and remote echo (the typical
usage) and nacks any other option the other end tries to negotiate.  It can
do bidirectional binary - but it doesn't strip to 7 bits if not in binary.

The other unique thing is it needs to read and write binary data out a file.
You may remember I've been asking about this lately.  This contains the
portable, hacked version.  That is, it may be horribly slow, but it lets you
read and write a NUL (and still detect EOF).

NOTE: The code for binary data has been extracted into "binary-io.tcl";
you will need to have that file in your auto_path.

I think the only tclX feature required is "server_open".  (I don't consider
the profiling support "required").

John
}

#lappend auto_path "PATH-TO binary-io.tcl"
lappend auto_path [file dir [pwd]] .


#
#
#

proc error { msg } { msg "Error: $msg"; exit }
proc msg { msg } { puts stderr "$msg" }

#
# 2 way arrays
#

proc Set { a s v } {
	global $a
	#puts stderr "$a $s $v"
	eval { set [set a]($s) $v }
	eval { set [set a]($v) $s }
}

#
# Telnet
#
Set Telnet IAC	255
Set Telnet DONT	254
Set Telnet DO	253
Set Telnet WONT	252
Set Telnet WILL	251
Set Telnet SB	250
Set Telnet GA	249
Set Telnet EL	248
Set Telnet EC	247
Set Telnet AYT	246
Set Telnet AO	245
Set Telnet IP	244
Set Telnet BREAK	243
Set Telnet DM	242
Set Telnet NOP	241
Set Telnet SE	240
Set Telnet EOR	239
Set Telnet ABORT	238
Set Telnet SUSP	237
Set Telnet xEOF	236

Set Telnet SYNCH	242

Set TelOpt BINARY	0
Set TelOpt ECHO	1
Set TelOpt RCP	2
Set TelOpt SGA	3
Set TelOpt NAMS	4
Set TelOpt STATUS	5
Set TelOpt TM	6
Set TelOpt RCTE	7
Set TelOpt NAOL	8
Set TelOpt NAOP	9
Set TelOpt NAOCRD	10
Set TelOpt NAOHTS	11
Set TelOpt NAOHTD	12
Set TelOpt NAOFFD	13
Set TelOpt NAOVTS	14
Set TelOpt NAOVTD	15
Set TelOpt NAOLFD	16
Set TelOpt XASCII	17
Set TelOpt LOGOUT	18
Set TelOpt BM	19
Set TelOpt DET	20
Set TelOpt SUPDUP	21
Set TelOpt SUPDUPOUTPUT 22
Set TelOpt SNDLOC	23
Set TelOpt TTYPE	24
Set TelOpt EOR	25
Set TelOpt TUID	26
Set TelOpt OUTMRK	27
Set TelOpt TTYLOC	28
Set TelOpt 3270REGIME	29
Set TelOpt X3PAD	30
Set TelOpt NAWS		31
Set TelOpt TSPEED	32
Set TelOpt LFLOW	33
Set TelOpt LINEMODE	34
Set TelOpt XDISPLOC	35
Set TelOpt ENVIRON	36
Set TelOpt AUTHENTICATION 45
Set TelOpt EXOPL	255

Set TelQual IS		0
Set TelQual SEND	0

set telbuf 1
set telidebug 0
set telodebug 0
set teloptdebug 0
set telbinary 0

Set TelResp DO WILL
Set TelResp DONT WONT

set TelOptRej(DO) WONT
set TelOptRej(WILL) DONT
set TelOptRej(WONT) ""
set TelOptRej(DONT) ""

proc TelnetNegot { io negot opt } {
	global Telnet TelOpt teloptdebug
	set i [lindex $io 0]
	set o [lindex $io 1]

	if {$teloptdebug} {
		puts stderr "\[send $negot $opt\]"
	}
	PutBytes $o $Telnet(IAC) $Telnet($negot) $TelOpt($opt)
}

proc TelnetHandleOpt { io negot opt } {
	global Telnet TelOpt teloptdebug
	global TelResp TelOptRej
	global TelWant TelSlaveOpt

	if {![info exists TelOpt($opt)]} {
		# unknown option
		Set TelOpt $opt $opt
	}
	if {$teloptdebug} {
		puts stderr "\[got $Telnet($negot) $TelOpt($opt)\]"
	}
	if {[info exists TelWant($Telnet($negot),$TelOpt($opt))]} {
		if {$teloptdebug} {
			puts stderr "\[$TelOpt($opt) just what I wanted\]"
		}
		return
	}
	if {[info exists TelSlaveOpt($TelOpt($opt))] && 
	    $TelSlaveOpt($TelOpt($opt)) != 0} {
		if {$teloptdebug} {
			puts stderr "\[$TelOpt($opt) slaved to other side\]"
		}
		if {$negot == $Telnet(WILL)} {TelnetNegot $io DO $TelOpt($opt)}
		return
	}
	if {$TelOptRej($Telnet($negot)) != ""} {
		TelnetNegot $io $TelOptRej($Telnet($negot)) $TelOpt($opt)
	}
}

proc TelnetWant { io negot opt } {
	global Telnet TelOpt teloptdebug TelResp TelWant

	set TelWant($TelResp($negot),$opt) 1
	TelnetNegot $io $negot $opt
}

proc Telnet { host port } {
	global TelSlaveOpt telbinary telbuf

	set io [server_open $host $port]
	set i [lindex $io 0]
	set o [lindex $io 1]
	if {$telbuf == 0} {
		fcntl $i NOBUF 1
	}
	# not yet - wait for bug fix in tcl7.0b3
	#fcntl $i NONBLOCK 1
	fcntl $o NOBUF 1

	if {$port != "telnet"} {return $io}

	TelnetWant $io DO SGA
	#set TelSlaveOpt(ECHO) 1
	TelnetWant $io DO ECHO

	if {$telbinary} {
		TelnetWant $io DO BINARY
		TelnetWant $io WILL BINARY
	}
	return $io
}

proc TelnetClose { io } {
	set i [lindex $io 0]
	set o [lindex $io 1]
	close $i
	close $o
}

proc TelnetReady { io } {
	set i [lindex $io 0]
	set o [lindex $io 1]
	set ready [select [list $i] {} {} {0}]
	set reads [lindex $ready 0]
	if { [lsearch $reads $i] == -1 } {
		return 0
	} else {
		return 1
	}
}

proc TelnetGetByte { io } {
	global telidebug
	set i [lindex $io 0]
	set o [lindex $io 1]
	set in [GetByte $i]
	if {$telidebug} {
		if {$in == -1} {
			puts -nonewline stderr {[EOF]}
		} else {
			if {($in < 32 && $in != 10 && $in != 13) || $in > 126} {
				puts -nonewline stderr [ format {<%02x } $in ]
			} else {
				puts -nonewline stderr [ format {<%c} $in ]
			}
		}
	}
	return $in
}

proc TelnetInput { io } {
	global Telnet telidebug

	while { [TelnetReady $io] } {
		set in [TelnetGetByte $io]
		if {$in == -1} {return 1}
		if {$in != $Telnet(IAC)} {
			puts -nonewline [ctype char $in]
			continue
		}

		set in [TelnetGetByte $io]
		if {$in == -1} {return 1}
		if {$in == $Telnet(DO) ||
		    $in == $Telnet(DONT) ||
		    $in == $Telnet(WILL) ||
		    $in == $Telnet(WONT)} {
			set opt [TelnetGetByte $io]
			if {$in == -1} {return 1}
			TelnetHandleOpt $io $in $opt
		} else {
			puts stderr "\[$Telnet($in) not implemented\]"
		}
	}
	return 0
}

proc TelnetWrite { io val } {
	global Telnet telodebug telcrlf
	set i [lindex $io 0]
	set o [lindex $io 1]

	if {$telodebug} {
		if {$val < 32 || $val > 126} {
			puts -nonewline stderr [ format {>%02x } $val ]
		} else {
			puts -nonewline stderr [ format {>%c} $val ]
		}
	}
	PutByte $o $val
	if {$val == 13} {
		PutByte $o 0
	}
	if {$val == $Telnet(IAC)} {
		PutByte $o $val
	}
}

#
# Main program - collect unit args into bitmap and invoke DirectCommand
#

set argc [llength $argv]

set isig ""
set profile 0
set quiet 0

for {set arg 0} {$arg < $argc} {incr arg} {
	switch -- [lindex $argv $arg] {
	-b	{set telbinary 1}
	-nobuf	{set telbuf 0}
	-i	{set isig "-isig"}
	-q	{set quiet 1}
	-dcmd	{cmdtrace on}
	-di	{set telidebug 1}
	-do	{set telodebug 1}
	-dopt	{set teloptdebug 1}
	-dprof	{set profile 1}
	default	{break}
	}
}

if {$argc - $arg != 1 && $argc - $arg != 2} {
	puts stderr {Usage: tcltelnet [-opts] hostname [port]}
	exit 1
}

set host [lindex $argv $arg]
if {$argc-$arg > 1} {set port [lindex $argv [incr arg]]} else {set port telnet}

#fcntl stdin NOBUF 1
#fcntl stdout NOBUF 1

# I use tcsh which automatically corrects these for me when the script exits
eval exec stty -echo -icanon $isig

set tio [Telnet $host $port]
set ti [lindex $tio 0]
set to [lindex $tio 1]
if {!$quiet} {puts stderr "Connected to $host"}
if {$profile} {profile on}
while { 1 } {
	set ready [select [list $ti stdin]]
	set reads [lindex $ready 0]

	if { [lsearch $reads file0] >= 0 } {
		set in [read stdin 1]
		if {[string length $in] == 0} {
			if [feof stdin] break else { TelnetWrite $tio 0 }
		} else {
			TelnetWrite $tio [ctype ord $in]
		}
	}
	if { [lsearch $reads $ti] >= 0 } {
		if [TelnetInput $tio] break
	}
}
if {!$quiet} {puts stderr "Connect closed by $host"}
TelnetClose $tio
if {$profile} {
	profile off telprof
	profrep telprof cpu 4 prof.tcltelnet
}
exit 0