PROGRAM TCPSAMPLE
C
C File name:	TCPSAMPLE.FOR
C Product:	TCPware for OpenVMS
C Version:	V5.6
C Edit level:	11
C
C Copyright (c) 2001, 2002 by
C Process Software LLC
C Framingham, Massachusetts
C
C Copyright (c) 2000 by
C Process Software
C Framingham, Massachusetts
C
C This software is furnished under a  license  for  use  on  a
C single  computer  system  and  may  be  copied only with the
C inclusion of the above copyright notice.  This  software, or
C any  other  copies thereof, may not be provided or otherwise
C made available to any other person except for  use  on  such
C system  and to one who agrees to these license terms.  Title
C to and ownership of the software shall at all  times  remain
C in Process Software LLC's name.
C
C The information  in  this  document  is  subject  to  change
C without  notice  and should not be construed as a commitment
C by  Process Software LLC.   Process Software LLC assumes  no
C responsibility for any errors that may appear in this document.
C
C
C This is a sample FORTRAN program that uses the TCPDRIVER
C services to transmit or receive data.  This program:
C	o Prompts for a host name,
C	o Uses the HNS_LOOKUPHOST function to get the internet
C	  address for the host,
C	o Prompts for the port number,
C	o Prompts for the operation (transmit or receive),
C	o Opens the connection (active if transmit or passive
C	  if receive),
C	o Transmits or receives data, and
C	o Closes the connection.
C
	INCLUDE		'($IODEF)'

	EXTERNAL	HNS_LOOKUPHOST
	INTEGER*4	HNS_LOOKUPHOST
	EXTERNAL	SYS$QIOW, SYS$ASSIGN
	INTEGER*4	SYS$QIOW, SYS$ASSIGN

	INTEGER*4	INTERNET_ADD, ISTAT, IO_DESC(2)
	INTEGER*2	PORT_NUM, TCP_CHAN, IOSB(4), INLEN

	CHARACTER	DIRECTION
	CHARACTER*132	DATBUF

	STRUCTURE	/ECB_RECORD/
		INTEGER*2	PID
		INTEGER*4	VALUE
	END STRUCTURE

	RECORD /ECB_RECORD/	BUFF(2)

	TYPE *,'TCPDRIVER SAMPLE PROGRAM'
C
C	Prompt the user for the host name, port number, and
C	transfer direction:
C
	CALL LIB$GET_INPUT(DATBUF,'Host Name ? ',INLEN)
	ISTAT = HNS_LOOKUPHOST(DATBUF(1:INLEN),INTERNET_ADD)
	IF (.NOT. ISTAT) THEN
	  TYPE *,'%SAMPLE-F-Failed to find host''s entry'
	  GOTO 1000
	END IF

	TYPE 121
121	FORMAT (' Port Number ? ',$)
	ACCEPT *,PORT_NUM

130	TYPE 131
131	FORMAT (' Operation (T=Transmit, R=Receive) ? ',$)
	ACCEPT 133, DIRECTION
133	FORMAT (A)
	IF (DIRECTION .EQ. 't') DIRECTION = 'T'
	IF (DIRECTION .EQ. 'r') DIRECTION = 'R'
	IF ((DIRECTION .NE. 'T') .AND. (DIRECTION .NE. 'R')) GOTO 130
C
C	Assign a channel to TCP driver:
C
	ISTAT = SYS$ASSIGN('_TCP0:',TCP_CHAN,,)
	IF (.NOT. ISTAT) THEN
	  TYPE *, '%SAMPLE-F-Failed to assign _TCP0:'
	  GOTO 1000
	END IF
C
C	Build the TCP extended characteristics buffer:
C
	IO_DESC(1)=2*6
	IO_DESC(2)=%LOC(BUFF)
	IF (DIRECTION .EQ. 'R') THEN
	  BUFF(1).PID = 1	! Local Port Number
	  BUFF(1).VALUE = PORT_NUM
	ELSE
	  BUFF(1).PID = 3	! Foreign Port Number
	  BUFF(1).VALUE = PORT_NUM
	END IF
	BUFF(2).PID = 2		! Foreign Internet Address
	BUFF(2).VALUE = INTERNET_ADD
C
C	Open the connection:
C
	IF (DIRECTION .EQ. 'T') THEN
	  ISTAT = SYS$QIOW(,%VAL(TCP_CHAN),%VAL(IO$_SETMODE
     +	          .OR. IO$M_CTRL .OR. IO$M_STARTUP),IOSB,,,,
     +	          %REF(IO_DESC),,,,)
	ELSE
	  ISTAT = SYS$QIOW(,%VAL(TCP_CHAN),%VAL(IO$_SETMODE
     +	          .OR. IO$M_CTRL .OR. IO$M_STARTUP .OR.
     +	          '0800'X),IOSB,,,,%REF(IO_DESC),,,,)
	END IF
	IF (ISTAT) ISTAT = IOSB(1)
	IF (.NOT. ISTAT) THEN
	  TYPE *,'%SAMPLE-F-Error during open', ISTAT
	  GOTO 1000
	END IF
C
C	Now transmit or receive data:
C
	IF (DIRECTION .EQ. 'R') GOTO 500
C
C	Transmit the current date and time:
C
	CALL LIB$DATE_TIME(DATBUF)
	DATBUF = 'The current date and time is '//
     +	         DATBUF(1:35)//CHAR(13)//CHAR(10)
	TYPE *, ' '
	TYPE *, 'The transmitted data is:'
	TYPE *, DATBUF
	ISTAT = SYS$QIOW(,%VAL(TCP_CHAN),%VAL(IO$_WRITEVBLK),IOSB,,,
     +          %REF(DATBUF),%VAL(INDEX(DATBUF,CHAR(10))),,,,)
	IF (ISTAT) ISTAT = IOSB(1)
	IF (.NOT. ISTAT) TYPE *,'%SAMPLE-W-Failed to transmit', ISTAT
	GOTO 900
C
C	Receive until an error status is returned:
C
500	ISTAT = SYS$QIOW(,%VAL(TCP_CHAN),%VAL(IO$_READVBLK),
     +          IOSB,,,%REF(DATBUF),%VAL(LEN(DATBUF)),,,,)
	IF (ISTAT) ISTAT = IOSB(1)
	IF (.NOT. ISTAT) GOTO 900
	TYPE *, ' '
	TYPE *, 'The received data is:'
	TYPE *, DATBUF(1:IOSB(2))
	GOTO 500
C
C	Close our side of the connection:
C
900	ISTAT = SYS$QIOW(,%VAL(TCP_CHAN),%VAL(IO$_SETMODE .OR.
     +	        IO$M_CTRL .OR. IO$M_SHUTDOWN),IOSB,,,,,,,,)
	IF (ISTAT) ISTAT = IOSB(1)
	IF (.NOT. ISTAT) TYPE *,'%SAMPLE-F-Error during close',ISTAT
C
C	Wait for peer to close his side of connection:
C
	IF (DIRECTION .EQ. 'R') GOTO 1000
910	ISTAT = SYS$QIOW(,%VAL(TCP_CHAN),%VAL(IO$_READVBLK),
     +          IOSB,,,%REF(DATBUF),%VAL(LEN(DATBUF)),,,,)
	IF (ISTAT) ISTAT = IOSB(1)
	IF (ISTAT) GOTO 910

1000	END