.title TCPLINK	Connect PTY to TCP socket

;++
;
; Program:	TCPLINK
; Author:	Don Stokes <don@zl2tnm.gen.nz>
; Date:		18-Oct-1994
;
; TCPLINK runs as a detached process to connect a TCP stream to a pseudo-
; terminal, using CMU IP.
;
; To run, the program needs thre pieces of information: a name to point at
; the created pseudo-terminal, the host name to connect to, and the TCP port 
; number to connect to the host on.  The first item is encoded into the process
; name, which must be in the form of TL$logname.  Since process names must be
; 15 characters or less, the logical name must fit into 12 characters.
;
; The host name and port numbers are passed through the (system) logical names
; TCPLINK$logname_HOST and TCP$logname_PORT.  
;
; Once started, TCPLINK will create the logical name pointing to the freshly
; created pseudo-terminal.
;
; The following DCL procedure can be used to create a TCPLINK port:
;
.if defined CUT_HERE ;----------------------------------------------------------
$	v = 'f$verify(0)'
$! @TCPLINK device host port
$	if p3 .eqs. ""
$	then	write SYS$OUTPUT "%TCPLINK-W-INSPRM, insufficient parameters"
$		exit
$	endif
$	device = f$extract(0,12,p1)
$	prcnam = "TL$" + device - ":"
$	assign/system/exec/nolog &p2 TCPLINK$'device'_HOST
$	assign/system/exec/nolog &p3 TCPLINK$'device'_PORT
$	run CMUIP_ROOT:[sysexe]TCPLINK /detach -
		/input	= NLA0: -
		/output	= CMUIP_ROOT:[sysmgr]TCPLINK$'device'.LOG -
		/error	= CMUIP_ROOT:[sysmgr]TCPLINK$'device'.LOG -
		/process= &prcnam
$	c = 0
$ 1:	if .not. f$getdvi(device, "EXISTS")
$	then	wait 0:0:1
$		c = c + 1
$		if c .lt. 20 then goto 1
$		write SYS$OUTPUT "%TCPLINK-W-TIMEOUT, timout waiting for device"
$		exit
$	endif
$	exit f$verify(v)*0+1
.endc ;-------------------------------------------------------------------------
;
; For example, a uucp-over-tcp feed on port 540 at uucphost.site.domain could
; be set up using DECUS UUCP as follows:
;
;	$ @TCPLINK UUCPFEED "uucphost.site.domain" 540
;	$ SET TERMINAL UUCPFEED:/PERMANENT/ALTYPAHD
;	$ SET PROTECTION=W:RWLP UUCPFEED:/DEVICE
;
; Then all that remains is to set up DECUS UUCP to use UUCPFEED: as a dialout
; line.
;
; To compile TCPLINK:
;	$ macro TCPLINK
;	$ link TCPLINK,NETERROR
;
; NETERROR.OBJ can be generated by the MESSAGE utility from NETERROR.MSG
; which is available from the CMUIP source saveset.  It's not actually
; necessary, but may help in debugging problems as it contains the CMU error
; messages.
;
;
; TCPLINK is Copyright 1994 Don Stokes, and may be freely distributed.
; Unauthorised commercial distribution is not permitted (ie: let's talk 8-)
;
; Please forward modifications, bug fixes, bug reports, queries, chocolate,
; offers of money etc to:
;
;	Don Stokes
;	Victoria University of Wellington, New Zealand
;	Email: don@zl2tnm.gen.nz (home), don@vuw.ac.nz (work)
;	Phone: +64 4 495-5052, Phax: +64 4 471-5386
;
; Warranty: you've *got* to be kidding.
;
;--


	.sbttl Macros etc
;
; Macros & miscellaneous definitions
;

		$PSLDEF			; Misc macros from STARLET.MLB
		$JPIDEF
		$DVIDEF
		$DEVDEF
		$LNMDEF
		$IODEF
		$SSDEF

NET$OPEN	= IO$_CREATE		; CMU function codes
NET$CLOSE	= IO$_DEACCESS
NET$SEND	= IO$_WRITEVBLK
NET$RECEIVE	= IO$_READVBLK

	.macro debug			; quick-n-dirty to fire up debugger
		pushl #SS$_DEBUG
		calls #1, g^LIB$SIGNAL
		.endm

	.macro status stat, ?L1		; Fatal error check
		blbs stat, L1
		.iif idn <R0>,<stat>, movzwl stat, R0
		;debug
		brw fatal
	L1:	.endm

	.macro cmustat iosb, ?L2	; Check for non-fatal CMU errors within
		blbs iosb, L2		; AST routines
		movab iosb, R0
		;debug
		brw cmu_non_fatal
	L2:	.endm

	.macro item code, buflen, address, lenadr=0
		.word buflen		; Item list entry for system services
		.word code
		.long address
		.long lenadr
		.endm

	.macro descriptor addr=0, len=0, type=T, class=S
		.word len		; String descriptor
		.byte DSC$K_DTYPE_'type'
		.byte DSC$K_CLASS_'class'
		.long addr
		.endm

	.macro output, msg		; Print a message
		pushaq msg
		calls #1, g^LIB$PUT_OUTPUT
		.endm


	.sbttl Data
;
; Data areas
;
	.psect TCPLINK_RW, long, noexe,wrt,noshr

;
; Logical name translations etc for port info
;
host_lnm_fao:	.ascid "TCPLINK$!AS_HOST"		; Host name
host_lnm_d:	.ascid "TCPLINK$xxxxxxxxxxxx_HOST"
host_d:		descriptor host, 79
host:		.blkb 80
host_itmlst:	item LNM$_STRING, 80, host, host_d
		item 0,0,0
port_lnm_fao:	.ascid "TCPLINK$!AS_PORT"		; Port number
port_lnm_d:	.ascid "TCPLINK$xxxxxxxxxxxx_PORT"
port_asc_d:	descriptor port_asc, 8
port_asc:	.blkb 8
port_d:		descriptor port, 2, L, S
port:		.blkl
port_itmlst:	item LNM$_STRING, 8, port_asc, port_asc_d
		item 0,0,0
jpi_itmlst:	item JPI$_PRCNAM, 15, jpi_prcnam, jpi_prcnam_d
		item 0,0,0				; Port name obtained
jpi_prcnam_d:	descriptor jpi_prcnam			; from process name
jpi_prcnam:	.blkl 16
lnm_d:		descriptor jpi_prcnam+3			; Logical name for port
crelnm_itmlst:	item LNM$_STRING, 0, tzan+8		; obtained from process
		item 0,0,0				; name
system_table:	.ascid "LNM$SYSTEM_TABLE"
lnm$file_dev:	.ascid "LNM$FILE_DEV"

;
; Stuff relating to pseudoterminals
;
pna0:		.ascid "PYA0"		; Template device for master side
					; of PN/TZ driver pair
tzan:		.ascid "tzaxxxx"	; TZAn device name to stuff into PCB

tz_dvi_itmlst1:	item DVI$_UNIT, 4, tz_unit
		item 0,0,0
tz_unit:	.blkl			; Unit number from $GETDVI
tz_fao:		.ascid "TWA!ZL:"	; FAO control string to contruct TZAn.
tz_dvi_itmlst2:	item DVI$_REFCNT, 4, tz_refcnt
		item 0,0,0		; $GETDVI itemlist to get ref counf
tz_refcnt:	.blkl
pnchan:		.blkw			; Channel
pniosb1:	.blkw 4			; Two IOSBs
pniosb2:	.blkw 4
pnbuf:		.blkb 512		; Buffer
pnbuf_l		= .-pnbuf

ip_dvi_itmlst:	item DVI$_DEVCHAR, 4, ip_devchar
		item 0,0,0		; $GETDVI itmelist to check if IP device
ip_devchar:	.blkl			; is available
ipchan:		.blkw			; Channel
ip:		.ascid "IP:"		; IP device name
ipiosb1:	.blkw 4			; Two IOSBs
ipiosb2:	.blkw 4
ipbuf:		.blkb 512		; Buffer
ipbuf_l		= .-ipbuf

;
; Misc stuff
;
one_sec:	.long -10000000		; Onse second delta time
		.long -1
diersn:		.long 0			; Status of IP services
msgbuf:		.blkb 256		; Stuff for translating same
msgbuf_l	= .-msgbuf
msgbuf_d:	descriptor msgbuf, msgbuf_l
faobuf:		.blkb 256		; Buffer for FAO
faobuf_l	= .-faobuf
faobuf_d:	descriptor faobuf, faobuf_l

;
; Messages
;
msg_open:	.ascid "%TCPLINK-I-OPEN, TCP link open"
msg_created:	.ascid "%TCPLINK-I-CREATED, created port !AS (!AS)!/" -
		       "-TCPLINK-I-WAITING, awaiting connects for !AZ:!UL"
msg_abort:	.ascid "%TCPLINK-W-ABORT, TCP error occured!/!AS"
msg_close:	.ascid "%TCPLINK-I-CLOSE, TCP link closed"
msg_shutdown:	.ascid "%TCPLINK-W-SHUTDOWN, TCP unavailable - exiting"


	.sbttl Initialisation
;
; Get program parameters
;
	.psect TCPLINK_RE, long, exe,nowrt,shr
	.entry tcplink, ^M<>
;
; Obtain port name, find port and host information, assign logical name for port
;
		$GETJPI_S itmlst=jpi_itmlst	; Get process name
		status R0
		subw3 #3, jpi_prcnam_d, lnm_d	; Set up descriptor for port

		$FAO_S ctrstr=host_lnm_fao, outlen=host_lnm_d, -
			outbuf=host_lnm_d, p1=#lnm_d
		status R0			; Format host name logical
		$TRNLNM_S tabnam=lnm$file_dev, lognam=host_lnm_d, -
			itmlst=host_itmlst	; Get host name
		status R0
		movzwl host_d, R0
		clrb host(R0)			; Convert to ASCIZ string

		$FAO_S ctrstr=port_lnm_fao, outlen=port_lnm_d, -
			outbuf=port_lnm_d, p1=#lnm_d
		status R0			; Format port number logical
		$TRNLNM_S tabnam=lnm$file_dev, lognam=port_lnm_d, -
			itmlst=port_itmlst	; Get port number
		status R0
		pushaq port_d
		pushaq port_asc_d
		calls #2, g^LIB$CVT_DX_DX	; Convert to long
		status R0

		$ASSIGN_S chan=pnchan, devnam=pna0
		status R0			; Get a PTY
		$GETDVI_S, chan=pnchan, itmlst=tz_dvi_itmlst1
		status R0			; Get its unit number
		$FAO_S ctrstr=tz_fao, outlen=tzan, outbuf=tzan, -
			p1=tz_unit		; Poke into a device name
		status R0

		movw tzan, crelnm_itmlst
		$CRELNM_S tabnam=system_table, lognam=lnm_d, -
			acmode=#PSL$C_EXEC, itmlst=crelnm_itmlst
		status R0			; Assign port name logical to
						; point to terminal side of PTY
		movw #faobuf_l, faobuf_d
		$FAO_S msg_created, faobuf_d, faobuf_d, #lnm_d,#tzan,#host,port
		output faobuf_d			; Say we're underway

		$SCHDWK_S daytim=one_sec, reptim=one_sec
		status R0			; We use a 1sec timer for lots


	.sbttl Main loop
;
; Wait for device to become busy, start comms, when device becomes inactive
; (or session shuts down), close everything off and start again
;

;
; Wait for PTY to be assigned
;
main_loop:	$GETDVI_S devnam=ip, itmlst=ip_dvi_itmlst
		status R0			; Check if IP device is active
		bitl #DEV$M_AVL, ip_devchar	; Bail out now if unavailable
		bneq 1$
		brw terminate
1$:		$GETDVI_S devnam=tzan, itmlst=tz_dvi_itmlst2
		status R0			; Get refcount of terminal side
		tstl tz_refcnt			; If active, get underway
		bneq 2$
		$HIBER_S			; Not active...
		status R0			; wait till next sec and go
		brb main_loop			; round again

;
; Connect TCP channel and start communications
;
2$:		clrl diersn			; We're alive

		$ASSIGN_S chan=ipchan, devnam=ip
		status R0			; Connect top IP0: device
		$QIOW_S chan=ipchan, iosb=ipiosb1, func=#NET$OPEN, -
			p1=host, p2=port, p4=#3, p6=#0
		status R0			; Connect TCP stream
		blbs ipiosb1, 21$		; If failed, bail out gracefully
		brw 6$

21$:		output msg_open			; Say we're off

		jsb ipqio			; Start copy from TCP to PTY
		jsb pnqio			; Start copy from PTY to TCP

;
; Inner loop -- let ASTs get on with the data transfer while we monitor the
; connection
;
3$:		$HIBER_S			; Wait a bit
		status R0
		tstl diersn			; If connection closes, exit
		bneq 5$

		$GETDVI_S, devnam=tzan, itmlst=tz_dvi_itmlst2
		status R0			; Check refcnt on PTY
		tstl tz_refcnt			; If zero, shut down
		beql 4$
		brw 3$				; Otherwise loop

;
; Exits from mail loop
;
4$:		incl diersn			; Come here if refcnt=0
						; use SS$_NORMAL as status

5$:		$QIOW_S chan=ipchan, iosb=ipiosb1, func=#NET$CLOSE, p1=0
		status R0			; Close TCP channel gracefullt
		blbs ipiosb1, 61$
6$:		movl ipiosb1+4, diersn		; Come here if open failed
61$:		$DASSGN_S chan=ipchan		; ... and deassign channel
		status R0
		$CANCEL_S chan=pnchan		; Kill off the PTY ASTs
		status R0

		cmpl diersn, #SS$_NORMAL	; If abnormal shutdown...
		beql 7$

		movw #msgbuf_l, msgbuf_d
		$GETMSG_S msgid=diersn, msglen=msgbuf_d, bufadr=msgbuf_d
		status R0			; Format message
		movb #^A"-", msgbuf		; Change % to -
		movw #faobuf_l, faobuf_d
		$FAO_S msg_abort, faobuf_d, faobuf_d, #msgbuf_d
		output faobuf_d			; Print %TTYLINK-W-ABORT message
						; followed by formatted error

7$:		output msg_close		; and report closure

8$:		$HIBER_S			; wait a bit
		status R0
		$GETDVI_S, devnam=tzan, itmlst=tz_dvi_itmlst2
		status R0			; if refcount still >0, wait 
		tstl tz_refcnt			; till refcnt is 0
		bneq 8$

		brw main_loop			; and go round again

;
; Come here if the IP device isn't available
;
terminate:	output msg_shutdown		; Report fact and exit
		$DASSGN_S chan=pnchan
		ret



	.sbttl AST to copy from TCP stream to PTY
;
; AST thet fires when QIO from IP channel completes
;
	.entry ipast, ^M<>
		cmpw ipiosb1, #SS$_CANCEL	; Check if CANCEL or ABORT
		beql 3$				; If so, exit without further 
		cmpw ipiosb1, #SS$_ABORT	; action.
		bneq 1$				; Do not requeue
3$:		ret				; Do not collect $200

1$:		cmustat ipiosb1			; Check status

		cvtwl ipiosb1+2, R0		; If empty, channel is closing
		beql 2$
		$QIOW_S chan=pnchan, iosb=pniosb2, func=#IO$_WRITEVBLK, -
			p1=ipbuf, p2=R0		; Write stuff received to PTY
		status R0
		status pniosb2

		jsb ipqio			; Requeue IO on TCP channel
		ret

2$:		movl #SS$_NORMAL, diersn	; Come here if length=0
		$WAKE_S				; Save status, and wake main 
		status R0			; process.  Do not requeue QIO
		ret

;
; Subroutine to queue read on TCP channel
;
ipqio:		$QIO_S chan=ipchan, iosb=ipiosb1, astadr=ipast, -
			func=#NET$RECEIVE, -
			p1=ipbuf, p2=#ipbuf_l
		status R0			; Boring QIO with completion AST
		rsb



	.sbttl AST to copy from PTY to TCP stream
;
; AST thet fires when QIO from IP channel completes
;
	.entry pnast, ^M<>

		cmpw pniosb1, #SS$_CANCEL	; Check that we're not being
		beql 1$				; kicked out, die quietly if
		cmpw pniosb1, #SS$_ABORT	; we are.
		beql 1$

		status pniosb1			; Check QIO status

		movzwl pniosb1+2, R0
		$QIOW_S chan=ipchan, iosb=ipiosb2, func=#NET$SEND, -
			p1=pnbuf, p2=R0, p4=#0 ; #1
		status R0			; Blat data received out TCP 
		cmustat ipiosb2			; port

		jsb pnqio			; Re-queue read to PTY

1$:		ret

;
; Subroutine to queue read on PTY
;
pnqio:		$QIO_S chan=pnchan, iosb=pniosb1, astadr=pnast, -
			func=#IO$_READVBLK, -
			p1=pnbuf, p2=#pnbuf_l
		status R0			; Another not very exciting QIO
		rsb


	.sbttl Error handling
;
; Error handling stuff
;
fatal:		$EXIT_S R0			; Quick abort

cmu_non_fatal:	movl 4(R0), diersn		; Error in IP stuff, put error
		$WAKE_S				; code in diersn and wake main
		ret				; thread



		.end tcplink