home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
gould2.zip
/
gm2kerm.f77
< prev
next >
Wrap
Text File
|
1988-08-16
|
147KB
|
5,100 lines
PROGRAM KERMIT
IMPLICIT NONE
C
C= File transfer program using kermit protocol
C
C
C REVISION LIST
C
C 1.0 This Kermit was the direct implemention of the Cyber-170
C version, University of Texas. L. Tate, SAI, Sept. 1985.
C
C 2.0 Added the CONNECT, GET, FINISH, BYE commands. This required
C significant changes to the io interface. The local on/off
C option was also part of this. L. Tate, SAI, Nov. 1985.
C
C 2.1 Correct bug in SUDT. When use the SVC 1,X'27' which
C set full duplex on a terminal it previously used a trashed
C file control block. This had caused unpredicatable results
C in alot of the io including 2 reads pending at once.
C Correcting this problem allowed removal of HIOALL routine.
C Files to be read are opened with OPENMODE='R' and files to
C be written are opened with OPENMODE='U'. Also added the
C TAKE command. L. Tate, SAI, Mar. 1986.
C
C 2.2 Improved receive/get reliablity by moving the terminal
C reporting to before the ACK/NAK is sent. The problem seems
C to have been during the reporting time, the sending flooded
C the 8-line buffer and caused a break, losing data. Also
C corrected error in printl routine which wrote to stdout
C instead of the parameter fd. L. Tate, SAI, Mar. 1986.
C
C 2.3 Added to SERVER the ability to recognize the I packet.
C This packet is used by advanced Kermits (2.27 at least)
C to initialize the Server.
C Changed the method by which nowait is established so that
C if ECHO was off for the terminal before kermit operation,
C it will remain so afterwards. Good for network operation.
C Corrected the error reporting code such that now the error
C messages are produced. However, they can be very cryptic.
C What is needed is a general method of handling text, like
C help messages and error messages, such that memory is not
C filled but ready access is available.
C L. TATE, SAI, MAY 1986.
C
C AS IN TO LFC=UT
C AS OUT TO LFC=UT
C
C
C
INCLUDE 'KVER.INS'
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KMSG.COM'
INCLUDE 'KDBUG.COM'
C
INTEGER NCMD ;PARAMETER (NCMD=15)
CHARACTER*10 CMD(NCMD) !commands
$ /'BYE', 'CONNECT','EXIT','FINISH','GET','HELP',
$ 'QUIT','RECEIVE','SEND','SERVER',
$ 'SET', 'SHOW', 'STATUS','TAKE', 'X'/
INTEGER NNOLOCAL ;PARAMETER (NNOLOCAL = 3)
CHARACTER*63 NOLOCAL (NNOLOCAL)
$/'This KERMIT does not support the following commands; BYE,',
$ 'CONNECT, FINISH, and GET. These commands require KERMIT',
$ 'to be installed on MPX3.2B or greater.'/
INTEGER IDX !current command
CHARACTER*80 CMDLIN !command line that started program
INTEGER IOS
C
INTEGER MATCH !get and match command
INTEGER OPEN
C
CALL SLINE(CMDLIN) !get startup command line
CALL INIT(CMDLIN) !pass to initialize
C
IOS = OPEN('STDIN','R')
IF (IOS .NE. STDIN) THEN
CALL PRTMSG(' Cannot open standard input', -IOS)
STOP
ENDIF
IOS = OPEN('STDOUT','W')
IF (IOS .NE. STDOUT) THEN
CALL PRTMSG(' Cannot open standard output',-IOS)
STOP
ENDIF
C
C initializing program
C
INPUTFD = OPEN('KERMIT.INI', 'R')
IF (INPUTFD .LE. 0) INPUTFD = STDIN
C
CALL PRINTL(STDOUT, VERSION)
DO, BEGIN
IF (INPUTFD .EQ. STDIN) THEN
CALL PUTSTR(STDOUT, PROMPT)
CALL FLUSH(STDOUT)
ENDIF
CALL FLUSH(INPUTFD)
IDX = MATCH(CMD, NCMD, .TRUE.)
IF (IDX .EQ. ERROR .OR. IDX .EQ. 0) GOTO 200
IF (IDX .EQ. EOF) THEN
IF (INPUTFD .NE. STDIN) THEN
CALL TAKEDONE
GOTO 200
ELSE
CALL EXITPGM
ENDIF
ENDIF
GOTO (130, 40, 50, 140, 20, 90, 50, 30, 10, 80, 100,
$ 110, 120, 60, 50) IDX
C
10 CONTINUE !send
CALL SNDFILE
GOTO 200
20 CONTINUE !get
IF (.NOT. LOCALON) GOTO 190
CALL GETFROM
GOTO 200
30 CONTINUE !receive
CALL RCVFILE
GOTO 200
40 CONTINUE !connect
IF (.NOT. LOCALON) GOTO 190
CALL CONNECT
GOTO 200
50 CONTINUE !exit
CALL EXITPGM
60 CONTINUE !take
CALL TAKE
GOTO 200
80 CONTINUE !server
CALL SERVER
GOTO 200
90 CONTINUE !help
CALL HELP
GOTO 200
100 CONTINUE !set
CALL SET
GOTO 200
110 CONTINUE !show
CALL SHOW
GOTO 200
120 CONTINUE !status
CALL STATUS
GOTO 200
130 CONTINUE !bye
IF (.NOT. LOCALON) GOTO 190
CALL BYE
GOTO 200
140 CONTINUE !finish
IF (.NOT. LOCALON) GOTO 190
CALL FINISH
GOTO 200
190 CONTINUE !no local
CALL OUTTBL(NOLOCAL, 1, NNOLOCAL)
GOTO 200
200 CONTINUE
ENDDO
END
SUBROUTINE INIT(COMLIN)
IMPLICIT NONE
CHARACTER*80 COMLIN !command line of program
C
C= initializes all kermit context
C
INCLUDE 'KVER.INS'
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
INCLUDE 'KMSG.COM'
C
INTEGER I !index
CHARACTER*2 MACH !machine type code
C
INTEGER LASTCHR !last non blank character
INTEGER ICHAR !character to int
INTEGER MATCH
INTEGER OPEN
C
C dbugcom
C
CALL M_UPRIV
CALL BREAKR
C
DEBUG = .FALSE. !no debug on
DBGFD = 0 !standoutput
DBGFILE = 'L.KERMLOG' !standoutput
C
C protcom
C
PACKET = 0
RECPACK = 0
FILESTR = 0
PSIZE = 0
PACKNUM = 0
NUMTRY = 0
MAXRTRY = MAXTRY
MAXRINI = MAXINIT
STATE = C
IFD = STDIN
OFD = STDOUT
COMPORT = 'UT'
FFD = 0
DELAYFP = 0
STARTIM = 0
ENDTIM = 0
SCHCNT = 0
RCHCNT = 0
SCHOVRH = 0
RCHOVRH = 0
ECHO = .FALSE.
ESCCHR = 29 ! CONTROL-]
LOG = .FALSE.
LFD = 0
LOGFILE = 'L.SESSION'
INSTACK = 0 !initialize stack pointer
INSTKFD = 0 !zero stack for good measure
C
C packcom
C
SYNC = SNDSYNC = SOH
PACKSIZ = SPKSIZ = MAXPACK
TIMEOUT = STIMOUT = MYTIME
NPAD = SPAD = MYPAD
PADCH = SPADCH = MYPADCH
EOLCH = SPEOL = MYEOL
QUOTECH = SPQUOTE = MYQUOTE
QUOTE8 = S8QUOTE = QUOT8CH
CHKTYP = SCHKTYP = MYCKTYP
RESERVE = UNUSED = 0
RPREFIX = SREPEAT = PREFXCH
C
C msgcom
C
IF (LOCALON) THEN
VERSION = 'Gould KERMIT version 2.3, Local/Remote enabled'
ELSE
VERSION = 'Gould KERMIT version 2.3, Local/Remote disabled'
ENDIF
CALL GETMACH(MACH)
PROMPT(1) = NEL
CALL DPC2AS('kermit-'//MACH//'>', PROMPT(2), 19)
I = LASTCHR(COMLIN)
IF (I .GT. 18 ) I = 18
IF (I .GT. 0) CALL DPC2AS(COMLIN(:I)//'>', PROMPT(2), I+1)
CLT 2.3 FIXED THE LOGIC FOR LNAME
I = 2
LNAME = 0
DO WHILE (PROMPT(I) .NE. ICHAR('>') .AND. I .LT. 21)
LNAME = LNAME + 1
NAME(LNAME) = PROMPT(I)
I = I + 1
ENDDO
C
CALL BREAKR
CALL X:SYNCH
C
RETURN
END
SUBROUTINE EXITPGM
IMPLICIT NONE
C
C= Exit kermit
C
INTEGER I !index
C
DO I=1, 10
CALL CLOSE(I)
ENDDO
STOP
END
SUBROUTINE RCVFILE
IMPLICIT NONE
C
C= Top level subroutine to start receive state.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
INTEGER RECEIVE !receive file
INTEGER GTTY !get tty status
LOGICAL CONFIRM !confirm input
C
IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
C receive file
C
CALL STTY(IFD, 'BINARY', ON)
CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
CALL STTY(IFD, 'NOWAIT', ON)
IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN
CALL PRINTL(STDOUT, 'Receiving file ')
CALL PUTSTR(STDOUT, FILESTR)
CALL FLUSH(STDOUT)
ENDIF
IF (RECEIVE(R) .EQ. OK) THEN
CALL PRINTL(STDOUT, 'Receive complete.')
ELSE
CALL PRINTL(STDOUT, 'Received failed.')
ENDIF
CALL STTY(IFD, 'NOWAIT', OFF)
CALL STTY(IFD, 'TIMEOUT', 0)
CALL STTY(IFD, 'BINARY', OFF)
RETURN
END
SUBROUTINE SNDFILE
IMPLICIT NONE
C
C= Sends a file to other kermit
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
CHARACTER*16 FNAME !name of file to send
INTEGER IRET !return status
C
LOGICAL ISFILE
INTEGER SEND
C
C pick up file name and save it for opening later
C
CALL SETVAL(FILESTR, 'S', IRET, 16, 0, 0,
$ 'Filename to send', .TRUE.)
IF (IRET .EQ. ERROR) RETURN
C
C check to make sure it's there to send
C
CALL AS2DPC(FILESTR, FNAME)
IF (.NOT. ISFILE(FNAME)) THEN
CALL PRINTL(STDOUT, '?File ')
CALL PUTSTR(STDOUT, FILESTR)
CALL PRINT(STDOUT,' is not found.')
CALL PUTC(STDOUT, NEL)
RETURN
ENDIF
C
CALL STTY(IFD, 'BINARY', ON)
CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
CALL STTY(IFD, 'NOWAIT', ON)
C
C delay the first packet
C
IF (DELAYFP .GT. 0) CALL SLEEP(DELAYFP)
C
C start sending packet
C
IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN
CALL PRINTL(STDOUT, 'Sending file ')
CALL PUTSTR(STDOUT, FILESTR)
CALL FLUSH(STDOUT)
ENDIF
PACKNUM = 0
IF (SEND() .EQ. OK) THEN
CALL PRINTL(STDOUT, 'Send complete.')
ELSE
CALL PRINTL(STDOUT, 'Send failed.')
ENDIF
CALL STTY(IFD, 'NOWAIT', OFF)
CALL STTY(IFD, 'TIMEOUT', 0)
CALL STTY(IFD, 'BINARY', OFF)
RETURN
END
SUBROUTINE SERVER
IMPLICIT NONE
C
C= Start kermit server routine
C
C The server currently knows about the send and receive packets
C and also the generic kermit packets logout and finish.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
INTEGER PTYP
INTEGER I
INTEGER NUM !packet number
INTEGER RECSTAT !receive status
INTEGER SNDSTAT !send status
CHARACTER*72 SRVMES (4 )
$ /'[Kermit server running on Gould host. Please type your',
$ 'escape sequence to return to your local machine. Shut',
$ 'down server by typing the Kermit BYE command on your',
$ 'local machine.]'/
CHARACTER*56 FILENAME
C
LOGICAL CONFIRM
INTEGER RDPACK !read a packet
INTEGER SNDPAR !build init packet
INTEGER GTTY !get terminal stuff
INTEGER RECEIVE !receive file
INTEGER SEND !send file
INTEGER LASTCHR !last non-blank character
INTEGER MAX
INTEGER SLEN !string length
LOGICAL*1 ISFILE !does file exist
C
IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
C initialize msg #, say no tries yet
C
PACKNUM = 0
NUMTRY = 0
CALL OUTTBL(SRVMES, 1, 4)
C
CALL STTY(IFD, 'BINARY', ON)
CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
CALL STTY(IFD, 'NOWAIT', ON)
C
10 CONTINUE
PTYP = RDPACK(LEN, NUM, RECPACK)
IF (PTYP .EQ. S) THEN
PACKNUM = NUM
CALL RDPARAM(RECPACK)
I = SNDPAR(PACKET)
CALL SNDPACK(Y, PACKNUM, I, PACKET)
NUMTRY = 0
PACKNUM = MOD(PACKNUM+1, 64)
RECSTAT = RECEIVE(F)
IF (DEBUG(DBGON)) THEN
IF (RECSTAT .EQ. ERROR) THEN
CALL PRINTL(DBGFD, 'Receive failed.')
ELSE
CALL PRINTL(DBGFD, 'Receive completed.')
ENDIF
ENDIF
ELSE IF (PTYP .EQ. R) THEN
I = 0
CALL STRCPY(RECPACK, FILESTR)
CALL AS2DPC(FILESTR, FILENAME)
CALL FILCHK(FILENAME)
C
CLT 2.3 5/12/86 CHECK TO SEE IF FILE EXISTS
C
IF (ISFILE(FILENAME)) THEN
CALL DPC2AS(FILENAME, FILESTR, MAX(1,LASTCHR(FILENAME)))
SNDSTAT = SEND()
PACKNUM = 0
IF (DEBUG(DBGON)) THEN
IF (SNDSTAT .EQ. ERROR) THEN
CALL PRINTL(DBGFD, 'Send failed.')
ELSE
CALL PRINTL(DBGFD, 'Send completed.')
ENDIF
ENDIF
CLT 2.3 5/12/86 SEND ERROR PACKET IF NOT FOUND
ELSE
CALL DPC2AS('? FILE ', PACKET, 7)
I = LASTCHR(FILENAME)
CALL DPC2AS(FILENAME, PACKET(8), I)
CALL DPC2AS(' NOT FOUND', PACKET(I+8), 10)
CALL SNDPACK(E, PACKNUM, SLEN(PACKET), PACKET)
ENDIF
ELSE IF (PTYP .EQ. G) THEN
IF (RECPACK(1) .EQ. L) THEN
CALL SNDPACK(Y, NUM, 0, 0)
CALL STTY(IFD, 'NOWAIT', OFF)
CALL STTY(IFD, 'TIMEOUT', 0)
CALL STTY(IFD, 'BINARY', OFF)
CALL EXITPGM !LOGOUT
ELSE IF (RECPACK(1) .EQ. F) THEN
CALL SNDPACK(Y, NUM, 0, 0)
CALL STTY(IFD, 'NOWAIT', OFF)
CALL STTY(IFD, 'TIMEOUT', 0)
CALL STTY(IFD, 'BINARY', OFF)
CALL EXITPGM
C
CLT 2.3 5/12/86 SEND ERROR MESSAGE FOR UNSUPPORTED COMMAND
C
ELSE
CALL DPC2AS('? UNSUPPORTED SERVER COMMAND', PACKET, 28)
CALL SNDPACK(E, PACKNUM, SLEN(PACKET), PACKET)
ENDIF
C
CLT 2.3 5/8/86 RECEIVE SERVER INIT PACKET
C
ELSE IF (PTYP .EQ. ITYP) THEN
PACKNUM = NUM
CALL RDPARAM(RECPACK)
I = SNDPAR(PACKET)
CALL SNDPACK(Y, PACKNUM, I, PACKET)
C
CLT END
C
ELSE
CLT 2.3 5/12/86 Added error message for unrecognized packet
CALL DPC2AS('? UNRECOGNIZED SERVER PACKET',PACKET,28)
CALL SNDPACK(E,PACKNUM, SLEN(PACKET), PACKET)
IF (DEBUG(DBGON)) THEN
CALL PRINTL(DBGFD, 'server: invalid packet type: ')
CALL PUTINT(DBGFD, PTYP, 1)
CALL FLUSH(DBGFD)
ENDIF
ENDIF
GOTO 10
END
SUBROUTINE SET
IMPLICIT NONE
C
C= Set some attributes.
C
INCLUDE 'KVER.INS'
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
INTEGER TSIZE !set commands
PARAMETER (TSIZE = 10)
CHARACTER*10 SETTYP(TSIZE)
$ /'DEBUG','DELAY','ECHO', 'ESCAPE',
$ 'INIT-RETRY','LOG','PORT','RECEIVE','RETRY','SEND'/
INTEGER NNOLOCAL ;PARAMETER (NNOLOCAL = 3 )
CHARACTER*63 NOLOCAL (NNOLOCAL)
$/'This KERMIT does not support the following SET commands;',
$ 'PORT and LOG. These commands require KERMIT to be installed',
$ 'on MPX3.2B or greater.'/
INTEGER INDX
INTEGER ESIZE ;PARAMETER (ESIZE = 2)
CHARACTER*3 ECHOTYP(ESIZE) /'OFF','ON'/
CHARACTER*63 HLPASCH/
$'Decimal, octal (O), or hexidecimal (H) code for ASCII character'
$/
C
INTEGER MATCH
C
INDX = MATCH (SETTYP, TSIZE, .FALSE.)
IF (INDX .LE. 0) RETURN
GOTO (10, 20, 23, 27, 30, 80, 70, 40, 50, 60) INDX
C
C set debugging modes
C
10 CONTINUE !debug
CALL DBUGCMD
RETURN
C
20 CONTINUE !set first packet delay
CALL SETVAL(DELAYFP,'I',0,60,0,60,
$ 'Number of seconds to delay first packet', .TRUE.)
RETURN
C
23 CONTINUE !set echo on/off
INDX = MATCH(ECHOTYP, ESIZE, .TRUE.)
IF (INDX .LE. 0) RETURN
ECHO = INDX .EQ. 2
RETURN
C
27 CONTINUE !escape
CALL SETVAL(ESCCHR, 'I', 0, 31, 0, 31, HLPASCH, .TRUE.)
RETURN
C
30 CONTINUE ! set initial packet retry count
CALL SETVAL(MAXRINI,'I',1,50,1,50,
$ 'Initial packet retry count', .TRUE.)
RETURN
C
40 CONTINUE !set receive packet attributes
CALL SETPACK(PACKSIZ)
RETURN
C
50 CONTINUE !set packet retry count
CALL SETVAL(MAXRTRY, 'I',1,50,1,50,
$ 'Packet retry count', .TRUE.)
RETURN
C
60 CONTINUE !set send packet attributes
CALL SETPACK(SPKSIZ)
RETURN
C
70 CONTINUE !set port
IF (.NOT. LOCALON) GOTO 90
CALL PORTCMD
RETURN
C
80 CONTINUE !set log
IF (.NOT. LOCALON) GOTO 90
CALL LOGGER
RETURN
C
90 CONTINUE !no local
CALL OUTTBL(NOLOCAL, 1, NNOLOCAL)
RETURN
END
SUBROUTINE SHOW
IMPLICIT NONE
C
C= Show the current program settings
C
INCLUDE 'KVER.INS'
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
INCLUDE 'KDBUG.COM'
INCLUDE 'KMSG.COM'
C
INTEGER MM,DD,YY,HR,MIN,SEC
C
INTEGER CTL
LOGICAL CONFIRM
C
IF (.NOT. CONFIRM(INPUTFD)) RETURN
CALL PRINTL(STDOUT, VERSION)
C
C display current date and time
C
CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
CALL PUTC(STDOUT, NEL)
CALL PUTDAY(STDOUT, MM, DD, YY)
CALL PRINT(STDOUT,', ')
CALL PUTMNTH(STDOUT,MM)
CALL PUTC(STDOUT,' ')
CALL PUTINT(STDOUT,DD, 1)
CALL PRINT(STDOUT,', ')
CALL PUTINT(STDOUT,YY, 1)
CALL PUTC(STDOUT,' ')
IF (HR .LT. 10) CALL PRINT(STDOUT,'0')
CALL PUTINT(STDOUT,HR,1)
CALL PUTC(STDOUT,':')
IF (MIN .LT. 10) CALL PRINT(STDOUT,'0')
CALL PUTINT(STDOUT,MIN,1)
CALL PUTC(STDOUT,':')
IF (SEC .LT. 10) CALL PRINT(STDOUT,'0')
CALL PUTINT(STDOUT,SEC,1)
C
C display current debug modes
C
CALL PRINTL(STDOUT,'Debugging: ')
IF (DEBUG(DBGSTAT)) CALL PRINT(STDOUT,'States ')
IF (DEBUG(DBGPACK)) CALL PRINT(STDOUT,'Packets ')
IF (.NOT. DEBUG(DBGON)) CALL PRINT(STDOUT,'Off ')
IF (DEBUG(DBGON)) THEN
CALL PRINT(STDOUT,' Debug log file: '//DBGFILE)
ENDIF
C
C session log
C
IF (LOCALON) THEN
CALL PRINTL(STDOUT, 'Session log: ')
IF (LOG) THEN
CALL PRINT(STDOUT, 'ON')
ELSE
CALL PRINT(STDOUT, 'OFF')
ENDIF
IF (LOGFILE .NE. ' ') THEN
CALL PRINT( STDOUT, ' Session log file: ')
CALL PRINT(STDOUT, LOGFILE)
ENDIF
ENDIF
C
C display current port
C
IF (LOCALON) THEN
CALL PRINTL(STDOUT, 'Selected Communications port: ')
CALL PRINT (STDOUT, COMPORT)
CALL PRINTL(STDOUT, 'Connection escape character: ^')
CALL PUTC(STDOUT, CTL(ESCCHR))
CALL PRINTL(STDOUT, 'Local echo: ')
IF (ECHO) THEN
CALL PRINT(STDOUT, 'ON')
ELSE
CALL PRINT(STDOUT, 'OFF')
ENDIF
ENDIF
C
C display packet settings
C
CALL PRINTL(STDOUT,'Packet Parameters')
CALL PRINTL(STDOUT,
$ ' Receive Send')
CALL PRINTL(STDOUT,' Size: ')
CALL PUTINT(STDOUT,PACKSIZ,10)
CALL PUTINT(STDOUT,SPKSIZ,10)
CALL PRINTL(STDOUT,' Timeout: ')
CALL PUTINT(STDOUT,TIMEOUT,10)
CALL PUTINT(STDOUT,STIMOUT,10)
CALL PRINTL(STDOUT,' Padding: ')
CALL PUTINT(STDOUT,NPAD,10)
CALL PUTINT(STDOUT,SPAD,10)
CALL PRINTL(STDOUT,' Pad character: ')
CALL PUTC(STDOUT,'^')
CALL PUTC(STDOUT,CTL(PADCH))
CALL PRINT(STDOUT,' ')
CALL PUTC(STDOUT,'^')
CALL PUTC(STDOUT,CTL(SPADCH))
CALL PRINTL(STDOUT,' End-of-Line: ')
CALL PUTC(STDOUT,'^')
CALL PUTC(STDOUT,CTL(EOLCH))
CALL PRINT(STDOUT,' ')
CALL PUTC(STDOUT,'^')
CALL PUTC(STDOUT,CTL(SPEOL))
CALL PRINTL(STDOUT,' Control quote: ')
CALL PUTC(STDOUT,QUOTECH)
CALL PRINT(STDOUT,' ')
CALL PUTC(STDOUT,SPQUOTE)
CALL PRINTL(STDOUT,' Start-of-Packet: ')
CALL PUTC(STDOUT,'^')
CALL PUTC(STDOUT,CTL(SYNC))
CALL PRINT(STDOUT,' ')
CALL PUTC(STDOUT,'^')
CALL PUTC(STDOUT,CTL(SNDSYNC))
C
C display protocol stuff
C
CALL PRINTL(STDOUT,'Delay before sending first packet: ')
CALL PUTINT(STDOUT,DELAYFP,1)
CALL PRINTL(STDOUT,'Init packet retry count: ')
CALL PUTINT(STDOUT,MAXRINI,1)
CALL PRINTL(STDOUT,'Packet retry count: ')
CALL PUTINT(STDOUT,MAXRTRY,1)
CALL PUTC(STDOUT,NEL)
RETURN
END
SUBROUTINE STATUS
IMPLICIT NONE
C
C= Tell how long last transfer took.
C
INCLUDE 'KVER.INS'
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
INCLUDE 'KTIME.COM'
C
INTEGER HR,MIN,SEC
INTEGER NSEC
C
LOGICAL CONFIRM
C
C confirm the command
C
IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
CALL PRINTL(STDOUT,'Max characters in packet: ')
CALL PUTINT(STDOUT, PACKSIZ, 1)
CALL PRINT(STDOUT,' received; ')
CALL PUTINT(STDOUT, SPKSIZ, 1)
CALL PRINT(STDOUT,' sent')
CALL PUTC(STDOUT,NEL)
IF (ENDTIM .LT. STARTIM) ENDTIM = ENDTIM + 86400
NSEC = ENDTIM - STARTIM
HR = NSEC / 3600
NSEC = NSEC - (HR * 3600)
MIN = NSEC / 60
NSEC = NSEC - (MIN * 60)
CALL PRINTL(STDOUT,'Number of characters transmitted in ')
IF (HR .GT. 0) THEN
CALL PUTINT(STDOUT,HR,1)
CALL PRINT(STDOUT,' hours ')
ENDIF
IF (MIN .GT. 0 .OR. HR .GT. 0) THEN
CALL PUTINT(STDOUT,MIN,1)
CALL PRINT(STDOUT,' minutes ')
ENDIF
CALL PUTINT(STDOUT,NSEC,1)
CALL PRINT(STDOUT,' seconds')
CALL PRINTL(STDOUT,' Sent: ')
CALL PUTINT(STDOUT, SCHCNT, 20)
CALL PRINT(STDOUT,' Overhead: ')
CALL PUTINT(STDOUT, SCHOVRH, 1)
CALL PRINTL(STDOUT,' Received: ')
CALL PUTINT(STDOUT, RCHCNT, 20)
CALL PRINT(STDOUT,' Overhead: ')
CALL PUTINT(STDOUT, RCHOVRH, 1)
CALL PRINTL(STDOUT,'Total Transmitted: ')
CALL PUTINT(STDOUT, RCHCNT+SCHCNT, 20)
CALL PRINT(STDOUT,' Overhead: ')
CALL PUTINT(STDOUT, RCHOVRH+SCHOVRH, 1)
CALL PUTC(STDOUT, NEL)
CALL PRINTL(STDOUT,'Total characters transmitted per sec: ')
CALL PUTINT(STDOUT,(SCHCNT+RCHCNT)/(ENDTIM-STARTIM),1)
CALL PRINTL(STDOUT,'Effective data rate: ')
CALL PUTINT(STDOUT,((SCHCNT+RCHCNT)-(SCHOVRH+RCHOVRH)) /
$ (ENDTIM-STARTIM) * 10, 1)
CALL PRINT(STDOUT,' baud')
CALL FLUSH(STDOUT)
IF (STATE .NE. C) THEN
CALL GETEMSG(PACKET)
CALL PRINTL(STDOUT,'?Kermit: ')
CALL PUTSTR(STDOUT, PACKET)
CALL FLUSH(STDOUT)
ENDIF
C
C timing
C
IF (LOCALON) THEN
CALL PRINTL(STDOUT, 'Connect timing averages: ')
CALL PRINT(STDOUT, 'GETC ')
CALL PUTINT(STDOUT, GETIME/GETCOUNT, 5)
CALL PRINT(STDOUT, ' PUTC ')
CALL PUTINT(STDOUT, PUTIME/PUTCOUNT, 5)
CALL PRINT(STDOUT, ' WAIT ')
CALL PUTINT(STDOUT, WAITIME/WAITCNT, 5)
CALL PRINT(STDOUT, ' TOTAL ')
CALL PUTINT(STDOUT, TOTIME, 5)
ENDIF
RETURN
END
SUBROUTINE DBUGCMD
IMPLICIT NONE
C
C= Set the debugging modes.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KDBUG.COM'
C
INTEGER DEBUGFN(17) !file name
INTEGER TSIZE ;PARAMETER (TSIZE = 5)
CHARACTER*10 DBGTYP(TSIZE)
$ /'ALL','LOG-FILE','OFF','PACKETS','STATES'/
INTEGER INDX
INTEGER IRET
C
INTEGER MATCH
LOGICAL CONFIRM
INTEGER OPEN
C
INDX = MATCH(DBGTYP, TSIZE, .FALSE.)
IF (INDX .LE. 0) RETURN
GOTO (10, 20, 30, 40, 50) INDX
C
10 CONTINUE !set all debug modes
DEBUG = .TRUE.
GOTO 100
C
20 CONTINUE !set logfile
CALL SETVAL(DEBUGFN, 'S', IRET, 16, 0, 0,
$ 'Debug output logfile specification', .TRUE.)
IF (IRET .EQ. OK) THEN
CALL AS2DPC(DEBUGFN, DBGFILE)
IF (DBGFD .NE. 0) THEN
CALL CLOSE(DBGFD)
DBGFD = 0
ENDIF
GOTO 100
ENDIF
RETURN
C
30 CONTINUE !turn off all debugging
DEBUG = .FALSE.
RETURN
C
40 CONTINUE !toggle debug packets
IF (.NOT. CONFIRM(INPUTFD))RETURN
DEBUG(DBGPACK) = .NOT. DEBUG(DBGPACK)
DEBUG(DBGON) = DEBUG(DBGPACK) .OR. DEBUG(DBGSTAT)
GOTO 100
C
50 CONTINUE !toggle debug states
IF (.NOT. CONFIRM(INPUTFD)) RETURN
DEBUG(DBGSTAT) = .NOT. DEBUG(DBGSTAT)
DEBUG(DBGON) = DEBUG(DBGPACK) .OR. DEBUG(DBGSTAT)
GOTO 100
C
100 CONTINUE !open the debug file in not done
IF (DBGFD .EQ. 0) THEN
DBGFD = OPEN(DBGFILE, 'W')
ENDIF
RETURN
END
SUBROUTINE SETPACK(ATTR)
IMPLICIT NONE
INTEGER ATTR(12) !attributes
C
C= Set packet send or receive attributes.
C
C Setpack will wet the attributes of the passed attribute list.
C This subroutine will set the appropriate packet parameter.
C The parameter to set is passed in an array and is very order
C dependent. See common block /packet/ for the ordering.
C Note that send and receive parameter ordering and storage
C size in the common block are identical. Keep it that way!
C
INCLUDE 'KDEF.INS'
C
INTEGER TSIZE ;PARAMETER (TSIZE=7)
CHARACTER*10 ATTRTYP(TSIZE) !commands
$ /'EOL','PACKLEN','PADCHR','PADLEN','QUOTECHR',
$ 'SYNCCHR','TIMEOUT'/
INTEGER INDX
CHARACTER*63 HLPASCH/
$'Decimal, octal (O), or hexidecimal (H) code for ASCII character'
$/
C
INTEGER MATCH
LOGICAL CONFIRM
C
INDX = MATCH(ATTRTYP, TSIZE, .FALSE.)
IF (INDX .LE. 0) RETURN
GOTO (10, 20, 30, 40, 50, 60, 70) INDX
C
10 CONTINUE !set eol character
CALL SETVAL(ATTR(5), 'I',1,31,127,127,HLPASCH,.TRUE.)
RETURN
C
20 CONTINUE !set maximum packet length
CALL SETVAL(ATTR(1), 'I',20,94,20,94,
$ 'Maximum packet length', .TRUE.)
RETURN
C
30 CONTINUE !set pad character
CALL SETVAL(ATTR(4), 'I', 0, 31, 127, 127, HLPASCH, .TRUE.)
RETURN
C
40 CONTINUE !set pad length
CALL SETVAL(ATTR(3), 'I', 0, 94, 0, 94,
$ 'Number of pad characters to use', .TRUE.)
RETURN
C
50 CONTINUE !set quote character
CALL SETVAL(ATTR(6), 'I',33, 62, 97, 126, HLPASCH, .TRUE.)
RETURN
C
60 CONTINUE !set sync character
CALL SETVAL(ATTR(12),'I', 0,127, 0, 127, HLPASCH, .TRUE.)
RETURN
C
70 CONTINUE !set timeout value
SETVAL (ATTR(2), 'I', 0, 94, 0, 94,
$ 'Number of seconds to wait before timeout', .TRUE.)
RETURN
END
SUBROUTINE PORTCMD
IMPLICIT NONE
C
C= Selects the port to be used.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
C
INTEGER PORTSTR(7) !port string to read
CHARACTER*6 PORTNM !char device name
CHARACTER*6 PORTWR !write port
INTEGER IRET !error code
INTEGER INEW !new input
INTEGER ONEW !new output
C
INTEGER OPEN !open port
INTEGER XTOI !hex ascii to integer
CHARACTER*4 ITOX !integer to hex ascii
C
CALL SETVAL(PORTSTR, 'S', IRET, 6, 0, 0,
$ 'Select communication port', .TRUE.)
IF (IRET .EQ. OK) THEN
CALL AS2DPC(PORTSTR, PORTNM)
C
IF (PORTNM .EQ. COMPORT) THEN !ignore no change
ELSE
C
C now open
C
IF (PORTNM .EQ. 'UT') THEN
IF (IFD .NE. STDIN) CALL CLOSE(IFD)
IF (OFD .NE. STDOUT) CALL CLOSE(OFD)
IFD = STDIN
OFD = STDOUT
COMPORT = PORTNM
ELSE
INEW = OPEN('@'//PORTNM,'R')
IF (INEW .LE. 0) THEN
CALL PRINTL(STDOUT, 'Failed to open read channel, code= ')
CALL PUTINT(STDOUT, -INEW, 3)
RETURN
ENDIF
PORTWR = PORTNM(1:2)
PORTWR(3:6) = ITOX(XTOI(PORTNM(3:6))+8)
ONEW = OPEN('@'//PORTWR,'W')
IF (ONEW .LE. 0) THEN
CALL CLOSE(INEW)
CALL PRINTL(STDOUT,'Failed to open write channel,code= ')
CALL PUTINT(STDOUT, -ONEW, 3)
RETURN
ENDIF
IF (IFD .NE. STDIN) CALL CLOSE(IFD)
IF (OFD .NE. STDOUT) CALL CLOSE(OFD)
COMPORT = PORTNM
IFD = INEW
OFD = ONEW
ENDIF
ENDIF
ENDIF
RETURN
END
SUBROUTINE CONNECT
IMPLICIT NONE
C
C= Connects stdin/stdout to in/out port
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KTIME.COM'
C
INTEGER BELL ;PARAMETER (BELL = X'07')
INTEGER ZERO ;PARAMETER (ZERO = X'30')
INTEGER BREAK ;PARAMETER (BREAK = X'42')
INTEGER CLOSE ;PARAMETER (CLOSE = X'43')
INTEGER QUIT ;PARAMETER (QUIT = X'51')
INTEGER RESUME ;PARAMETER (RESUME=X'52')
INTEGER LOWA ;PARAMETER (LOWA = X'61')
INTEGER LOWZ ;PARAMETER (LOWZ = X'7A')
INTEGER LOW2UP ;PARAMETER (LOW2UP = X'20')
INTEGER INCHR !char from stdin
INTEGER TTCHR !char from port
CHARACTER*10 CNUM !character
CHARACTER*10 CNUM2
INTEGER STIME
INTEGER FTIME
CLT LOGICAL PAUSER !XXX
CLT LOGICAL DUMPER !XXX
C
INTEGER GETC !get character
LOGICAL CONFIRM !confirm connect
INTEGER CTL !convert ctl to non-control
CHARACTER*(*)ITOA
CLT LOGICAL OPTION !XXX
C
IF (.NOT. CONFIRM(INPUTFD)) RETURN
CLT PAUSER = OPTION (1) !XXX
CLT DUMPER = OPTION (2) !XXX
C
IF (IFD .EQ. STDIN .OR. OFD .EQ. STDOUT) THEN
CALL PRINTL(STDOUT, '?No external port selected.')
RETURN
ENDIF
C
CALL PUTC(STDOUT, NEL)
CALL PRINT(STDOUT, '[Connecting to port, type ^')
CALL PUTC(STDOUT, CTL(ESCCHR))
CALL PRINT(STDOUT, ' C to return to local]')
CALL PUTC(STDOUT, NEL)
CALL PUTC(STDOUT, NEL)
C
CALL STTY(STDIN, 'BINARY', ON)
CALL STTY(STDIN, 'SIZE', 1)
CALL STTY(STDOUT, 'SIZE', 1)
CALL STTY(STDIN, 'NOWAIT', ON)
CALL STTY(STDOUT, 'NOWAIT', ON)
CALL STTY(IFD, 'BINARY', ON)
CALL STTY(IFD, 'SIZE', 1)
CALL STTY(OFD, 'SIZE', 1)
CALL STTY(IFD, 'NOWAIT', ON)
CALL STTY(OFD, 'NOWAIT', ON)
GETIME = PUTIME = 0
GETCOUNT = PUTCOUNT = 0
WAITIME = WAITCNT = 0
CALL MSEC(TOTIME)
C
DO, BEGIN
CLT IF (DUMPER) CALL DUMPF('BEGIN') !XXX
CLT IF (PAUSER) PAUSE BEGIN !XXX
CALL MSEC(STIME)
INCHR = GETC(STDIN, INCHR)
CALL MSEC(FTIME)
CLT IF (DUMPER) CALL DUMPF('AFTER STDIN') !XXX
GETCOUNT = GETCOUNT + 1
GETIME = FTIME - STIME + GETIME
CALL MSEC(STIME)
TTCHR = GETC(IFD, TTCHR)
CALL MSEC(FTIME)
GETCOUNT = GETCOUNT + 1
GETIME = FTIME - STIME + GETIME
C
CLT IF (INCHR .NE. ERROR .OR. TTCHR .NE. ERROR) THEN
CLT CNUM = ITOA(INCHR)
CLT CNUM2 = ITOA(TTCHR)
CLT CALL DISPLAY('KERMIT/CONNECT - PARSE CHARACTER'//CNUM//CNUM2)
CLT ENDIF
IF (INCHR .EQ. EOF) THEN
CLT CALL DISPLAY('KERMIT/CONNECT - EOF')
LEAVE
ELSE IF (INCHR .EQ. ERROR) THEN
CONTINUE
ELSE IF (INCHR .EQ. ESCCHR) THEN
10 CONTINUE
CLT CALL DISPLAY('KERMIT/CONNECT - WAIT FOR NON-ERROR')
DO WHILE (GETC(STDIN, INCHR) .EQ. ERROR)
CALL IOWAIT(50 )
ENDDO
IF (INCHR .GE. LOWA .AND. INCHR .LE. LOWZ)
$ INCHR = INCHR - LOW2UP
CNUM = ITOA(INCHR)
CLT CALL DISPLAY('KERMIT/CONNECT - NON-ERROR ='//CNUM)
IF (INCHR .EQ. CLOSE) THEN
LEAVE
ELSE IF (INCHR .EQ. BREAK) THEN
CALL SENDBRK(OFD)
ELSE IF (INCHR .EQ. ZERO) THEN
CALL PUTC(OFD, 0)
ELSE IF (INCHR .EQ. QUIT) THEN
LOG = .FALSE.
ELSE IF (INCHR .EQ. RESUME) THEN
IF (FFD .NE. 0) LOG = .TRUE.
ELSE IF (INCHR .EQ. ESCCHR) THEN
CALL PUTC(OFD, ESCCHR)
ELSE IF (INCHR .EQ. QMARK) THEN
CALL STTY(STDOUT, 'SIZE', -1)
CALL STTY(STDOUT, 'NOWAIT', OFF)
CALL PRINTL(STDOUT,'0 Send NULL')
CALL PRINTL(STDOUT,'B Send BREAK')
CALL PRINTL(STDOUT,'C Close connection')
CALL PRINTL(STDOUT,'Q Quit logging')
CALL PRINTL(STDOUT,'R Resume logging')
CALL PUTC(STDOUT, NEL)
CALL PRINT(STDOUT, '^')
CALL PUTC(STDOUT, CTL(ESCCHR))
CALL PRINT(STDOUT,' Send this character')
CALL PRINTL(STDOUT,'? This message')
CALL PRINTL(STDOUT,'Command>')
CALL STTY(STDOUT, 'NOWAIT', ON)
CALL STTY(STDOUT, 'SIZE', 1)
GOTO 10
ELSE
CALL PUTC(STDOUT, BELL)
ENDIF
ELSE
CLT CALL DISPLAY('KERMIT/CONNECT - PUTC OFD')
CALL MSEC(STIME)
CALL PUTC(OFD, INCHR)
CALL MSEC(FTIME)
PUTCOUNT = PUTCOUNT + 1
PUTIME = PUTIME + FTIME - STIME
IF (ECHO) CALL PUTC(STDOUT, INCHR)
ENDIF
C
IF (TTCHR .EQ. EOF) THEN
CALL PRINTL(STDOUT, '?EOF on port connection')
LEAVE
ELSE IF (TTCHR .EQ. ERROR) THEN
CONTINUE
ELSE
CLT CALL DISPLAY('KERMIT/CONNECT - PUTC STDOUT')
CALL MSEC(STIME)
CALL PUTC(STDOUT, TTCHR)
CALL MSEC(FTIME)
PUTIME = PUTIME + FTIME - STIME
PUTCOUNT = PUTCOUNT + 1
IF (LOG) THEN
IF (TTCHR .GE. BLANK .AND. TTCHR .LT. DEL) THEN
CALL PUTC(LFD, TTCHR)
ELSE IF (TTCHR .EQ. CR) THEN
CALL PUTC(LFD, NEL)
ENDIF
ENDIF
ENDIF
C
CALL MSEC(STIME)
IF (TTCHR .EQ. ERROR .AND. INCHR .EQ. ERROR) THEN
CALL IOWAIT(50 )
ENDIF
CALL MSEC(FTIME)
WAITIME = WAITIME + FTIME - STIME
WAITCNT = WAITCNT + 1
C
ENDDO
CLT IF (DUMPER) CALL DUMPF('ENDDO') !XXX
CLT IF (PAUSER) PAUSE ENDDO !XXX
C
CALL MSEC(FTIME)
TOTIME = FTIME - TOTIME
CALL FLUSH(IFD)
CALL FLUSH(STDIN)
CALL STTY(STDIN, 'BINARY', OFF)
CALL STTY(STDIN, 'SIZE', 80)
CALL STTY(STDOUT, 'SIZE', -1)
CALL STTY(STDIN, 'NOWAIT', OFF)
CALL STTY(STDOUT, 'NOWAIT', OFF)
CALL STTY(IFD, 'BINARY', OFF)
CALL STTY(IFD, 'SIZE', -1)
CALL STTY(OFD, 'SIZE', -1)
CALL STTY(IFD, 'NOWAIT', OFF)
CALL STTY(OFD, 'NOWAIT', OFF)
CLT IF (DUMPER) CALL DUMPF('EXIT CONNECT') !XXX
C
RETURN
END
SUBROUTINE LOGGER
IMPLICIT NONE
C
C= Performs log command
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
C
INTEGER NCMD ;PARAMETER (NCMD = 3)
CHARACTER*8 CMD(NCMD)
$ /'LOG-FILE', 'OFF', 'ON'/
INTEGER IRET
INTEGER TSTR(17) !temp file string
INTEGER INDX
C
INTEGER MATCH
INTEGER OPEN !open file
C
INDX = MATCH(CMD, NCMD, .FALSE.)
IF (INDX .LE. 0) RETURN
C
GOTO (10, 20, 30) INDX
C
10 CONTINUE
CALL SETVAL(TSTR, 'S', IRET, 16, 0, 0,
$ 'Session log filename', .TRUE.)
IF (IRET .EQ. OK) THEN
CALL AS2DPC(TSTR, LOGFILE)
LFD = OPEN(LOGFILE, 'W')
IF (LFD .LE. 0) THEN
CALL PRINTL(STDOUT, '?Failed to open session log file ')
CALL PUTINT(STDOUT, -LFD, 3)
LOG = .FALSE.
ELSE
LOG = .TRUE.
ENDIF
ENDIF
GOTO 100
C
20 CONTINUE
LOG = .FALSE.
IF (LFD .GT. 0) CALL CLOSE(LFD)
GOTO 100
C
30 CONTINUE
IF (LFD .EQ. 0) THEN
LFD = OPEN(LOGFILE, 'W')
IF (LFD .EQ. ERROR)
$ CALL PRINTL(STDOUT, '?Failed to open session log file')
ENDIF
LOG = LFD .GT. 0
GOTO 100
C
100 CONTINUE
RETURN
END
SUBROUTINE FINISH
IMPLICIT NONE
C
C= Sends finish command to target port
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
INTEGER PTYP, LEN, NUM
C
LOGICAL CONFIRM
INTEGER RDPACK
C
IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
IF (IFD .EQ. STDIN ) THEN
CALL PRINTL(STDOUT, '?No communication port selected.')
RETURN
ENDIF
C
CALL STTY(IFD, 'BINARY', ON)
CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
CALL STTY(IFD, 'NOWAIT', ON)
NUMTRY = 0
PACKET(1) = F !f is constant , fort codes as halfw.
DO WHILE (NUMTRY .LE. MAXTRY)
NUMTRY = NUMTRY + 1
CALL SNDPACK(G, 0, 1, PACKET)
PTYP = RDPACK(LEN, NUM, RECPACK)
IF (PTYP .EQ. Y) LEAVE
ENDDO
CALL STTY(IFD, 'NOWAIT', OFF)
CALL STTY(IFD, 'TIMEOUT', 0)
CALL STTY(IFD, 'BINARY', OFF)
RETURN
END
SUBROUTINE BYE
IMPLICIT NONE
C
C= Sends bye to remote and exits kermit
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
INTEGER PTYP !packet type
INTEGER LEN, NUM
C
LOGICAL CONFIRM
INTEGER RDPACK
C
IF (.NOT. CONFIRM(INPUTFD)) RETURN
C
CALL STTY(IFD, 'BINARY', ON)
CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
CALL STTY(IFD, 'NOWAIT', ON)
IF (IFD .EQ. STDIN ) THEN
CALL PRINTL(STDOUT, '?No communication port selected.')
RETURN
END IF
C
PACKET(1) = L
NUMTRY = 0
DO WHILE (NUMTRY .LE. MAXTRY)
NUMTRY = NUMTRY + 1
CALL SNDPACK(G, 0, 1, PACKET)
PTYP = RDPACK(LEN, NUM, RECPACK)
IF (PTYP .EQ. Y) LEAVE
ENDDO
CALL STTY(IFD, 'NOWAIT', OFF)
CALL STTY(IFD, 'TIMEOUT', 0)
CALL STTY(IFD, 'BINARY', OFF)
CALL EXITPGM
END
SUBROUTINE GETFROM
IMPLICIT NONE
C
C= Get file from remote server
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
INTEGER IRET !return status
INTEGER PTYP !packet type
INTEGER LEN
INTEGER NUM
C
INTEGER SLEN !length of string
INTEGER RECEIVE
INTEGER MOD
INTEGER RDPACK !read packet
INTEGER SNDPAR !pack send parameters
C
CALL SETVAL(FILESTR, 'S', IRET, 16, 0, 0,
$ 'Filename to get', .TRUE.)
IF (IRET .EQ. ERROR) RETURN
C
IF (IFD .EQ. STDIN) THEN
CALL PRINTL(STDOUT, '?No communication port selected.')
RETURN
END IF
C
IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN
CALL PRINTL(STDOUT, 'Getting file ')
CALL PUTSTR(STDOUT, FILESTR)
CALL FLUSH(STDOUT)
ENDIF
C
CALL STTY(IFD, 'BINARY', ON)
CALL STTY(IFD, 'TIMEOUT', TIMEOUT)
CALL STTY(IFD, 'NOWAIT', ON)
C
NUMTRY = 0
DO WHILE (NUMTRY .LE. MAXRINI)
NUMTRY = NUMTRY + 1
CALL SNDPACK(R, 0, SLEN(FILESTR), FILESTR)
PTYP = RDPACK(LEN, NUM, RECPACK)
IF (PTYP .EQ. S) THEN
PACKNUM = NUM
CALL RDPARAM(RECPACK)
LEN = SNDPAR(PACKET)
CALL SNDPACK(Y, PACKNUM, LEN, PACKET)
NUMTRY = 0
PACKNUM = MOD(PACKNUM+1, 64)
IF (RECEIVE(F) .EQ. OK) THEN
CALL PRINTL(STDOUT, 'Receive complete.')
ELSE
CALL PRINTL(STDOUT, 'Receive failed.')
ENDIF
LEAVE
ENDIF
ENDDO
CALL STTY(IFD, 'NOWAIT', OFF)
CALL STTY(IFD, 'TIMEOUT', 0)
CALL STTY(IFD, 'BINARY', OFF)
RETURN
END
SUBROUTINE TAKE
IMPLICIT NONE
C
C Provides a means to redirect input to file.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
C
INTEGER TAKEFILE(17) !take file input name
CHARACTER*16 CTAKEFIL !input file name
INTEGER IRET !return code
INTEGER TAKEFD !file desc to take from
C
LOGICAL ISFILE !check for file existence
INTEGER OPEN
C
C
CALL SETVAL(TAKEFILE, 'S', IRET, 16, 0, 0,
$ 'Filename to take commands from',.TRUE.)
IF (IRET .EQ. ERROR) RETURN
C
C check to make sure it's there
C
CALL AS2DPC(TAKEFILE, CTAKEFIL)
IF (.NOT. ISFILE(CTAKEFIL)) THEN
CALL PRINTL(STDOUT, '?File ')
CALL PUTSTR(STDOUT, TAKEFILE)
CALL PRINT(STDOUT, ' is not found.')
CALL PUTC(STDOUT, NEL)
RETURN
ENDIF
C
C open file
C
IF (INSTACK .GE. MAXINSTK) THEN
CALL PRINTL(STDOUT, '?Exceed input TAKE stack depth.')
RETURN
ENDIF
TAKEFD = OPEN(CTAKEFIL, 'R')
IF (TAKEFD .EQ. ERROR) THEN
CALL PRINTL(STDOUT, '?Cannot open ')
CALL PUTSTR(STDOUT, TAKEFILE)
CALL PRINT(STDOUT, '.')
CALL PUTC(STDOUT, NEL)
RETURN
ENDIF
C
C remember where was
C
INSTACK = INSTACK + 1
INSTKFD(INSTACK) = INPUTFD
C
C redirect
C
INPUTFD = TAKEFD
RETURN
END
SUBROUTINE TAKEDONE
IMPLICIT NONE
C
C= Returns to next level of input file.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
C
IF (INPUTFD .NE. STDIN) CALL CLOSE(INPUTFD)
IF (INSTACK .LE. 0) THEN
INSTACK = 0
INPUTFD = STDIN
ELSE
INPUTFD = INSTKFD(INSTACK)
INSTACK = INSTACK - 1
ENDIF
RETURN
END
INTEGER FUNCTION MATCH (TABLE, TABLEN, NELOK)
IMPLICIT NONE
CHARACTER*(*) TABLE(*) !table of commands
INTEGER TABLEN !number of elements
LOGICAL NELOK
C
C= Decides which input came in, handles ? help
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
C
CHARACTER*40 WORD !word to input
INTEGER ASTR(41) !ascii string
INTEGER LEN !length of word
INTEGER T1, T2 !internal indexes
INTEGER CHP !character pointer
C
INTEGER GETWORD !get word from input
C
LEN = GETWORD(INPUTFD, ASTR, 40)
IF (LEN .EQ. 0 .OR. LEN .EQ. EOF) THEN
MATCH = LEN
IF (LEN .EQ. 0 .AND. .NOT. NELOK) THEN
MATCH = ERROR
CALL PRINTL(STDOUT, '? Null switch or keyword given')
ENDIF
RETURN
ENDIF
CALL AS2DPC(ASTR, WORD)
C
C begin matching
C
T1 = 1
T2 = TABLEN
CHP = 1
DO WHILE (CHP .LE. LEN)
C
C if we find a ?, the give the possiblities
C
IF (WORD(CHP:CHP) .EQ. '?') THEN
CALL PRINTL(STDOUT, 'One of the following:')
CALL OUTTBL(TABLE, T1, T2)
MATCH = ERROR
RETURN
ENDIF
C
C while word is less than lower table entry
C
DO WHILE (WORD(CHP:CHP) .GT. TABLE(T1)(CHP:CHP) .AND.
$ T1 .LE. T2)
T1 = T1 + 1
ENDDO
C
C while word is greater than upper table entry
DO WHILE (WORD(CHP:CHP) .LT. TABLE(T2)(CHP:CHP) .AND.
$ T2 .GE. T1)
T2 = T2 - 1
ENDDO
C
C if we know we have a mismatch
C
IF (T2 .LT. T1) THEN
CALL PRINTL(STDOUT, '? Does not match switch or keyword - '//
$ WORD)
MATCH = ERROR
RETURN
ENDIF
CHP = CHP + 1
ENDDO
C
C after looking at the whole word, is it still ambiguous
C
IF (T1 .NE. T2) THEN
CALL PRINTL(STDOUT, '? Ambigious - '//WORD)
MATCH = ERROR
ELSE
MATCH = T1
ENDIF
RETURN
END
SUBROUTINE OUTTBL(TABLE, START, FIN)
IMPLICIT NONE
CHARACTER*(*) TABLE (*) !table to output
INTEGER START !start of table
INTEGER FIN !end of table
C
C= Outputs table in table format
C
INCLUDE 'KDEF.INS'
C
INTEGER ICOL !column
CHARACTER*80 LINE !output line
INTEGER NCOLS !number of columns
INTEGER IPOS
INTEGER I
INTEGER COLWID !width of column
INTEGER NL !last character in line
INTEGER LINECNT !count of lines output
C
INTEGER LASTCHR !last non-blank character in line
LOGICAL MORE !continue on
C
LINECNT = 0
COLWID = LEN(TABLE) + 2
NCOLS = 80 / COLWID
LINE = ' '
ICOL = 1
DO I=START, FIN
IPOS = (ICOL - 1) * COLWID + 1
LINE (IPOS:) = TABLE(I)
ICOL = ICOL + 1
IF (ICOL .GT. NCOLS .OR. I .EQ. FIN) THEN
NL = LASTCHR(LINE)
IF (NL .LE. 0) NL = 1
LINECNT = LINECNT + 1
IF (LINECNT .GE. 23) THEN
IF (.NOT. MORE()) RETURN
LINECNT = 0
ENDIF
CALL PRINTL(STDOUT, LINE(:NL))
LINE = ' '
ICOL = 1
ENDIF
ENDDO
RETURN
END
LOGICAL FUNCTION CONFIRM (FD)
IMPLICIT NONE
INTEGER FD !file device
C
C= Looks for a newline to confirm command
C
C Confirm will expect that the next token of input be a
C newline for confirmation to be true. If the next token
C is a question mark, then confirmation is false and a
C "confirm with a carriage return" message will be displayed'
C any other text will cause a 'not confirmed text message
C to be displayed and confirm will return false
C
INCLUDE 'KDEF.INS'
C
INTEGER CH !character input
C
INTEGER GETC !get character
C
CONFIRM = .FALSE.
10 CONTINUE
IF (GETC(FD, CH) .EQ. NEL) THEN
CONFIRM = .TRUE.
ELSE IF (CH .EQ. EOF) THEN
RETURN
ELSE IF (CH .EQ. BLANK .OR. CH .EQ. TAB) THEN
GOTO 10
ELSE IF (CH .EQ. QMARK) THEN
CALL PRINTL(STDOUT, 'Confirm with a carriage return')
ELSE
CALL PRINTL(STDOUT, '? Not confirmed - ')
20 CONTINUE
CALL PUTC(STDOUT, CH)
CH = GETC(FD, CH)
IF (CH .NE. NEL .AND. CH .NE. EOF) GOTO 20
CALL PUTC(STDOUT, NEL)
ENDIF
RETURN
END
SUBROUTINE SETVAL(VAR, VTYP, MN1, MX1, MN2, MX2, HLPMSG,
$ CONFRM)
IMPLICIT NONE
INTEGER VAR(41) !string to fill
CHARACTER*1 VTYP !type of input (s, i)
INTEGER MN1 !error code minimum value
INTEGER MX1 !length of string maximum value
INTEGER MN2 ! minimum value
INTEGER MX2 ! maximum value
CHARACTER*(*) HLPMSG !help message to output
LOGICAL CONFRM !must confirm
C
C= Reads input of specified type within range of parameters for int.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
C
INTEGER STR(41) !input string
INTEGER LEN
INTEGER I
C
LOGICAL CONFIRM !confirm input
INTEGER CTOI !character to integer
INTEGER GETWORD !get a word from input
C
LEN = GETWORD(INPUTFD, STR, 40)
IF (LEN .EQ. 0 .OR. LEN .EQ. EOF) THEN
IF (VTYP .EQ. 'I') THEN
CALL PRINTL(STDOUT,'First nonspace character is not a digit')
ELSE
CALL PRINTL(STDOUT,'Invalid, Missing parameter')
MN1 = ERROR
ENDIF
RETURN
ENDIF
IF (STR(1) .EQ. QMARK) THEN
CALL PRINTL(STDOUT, HLPMSG)
CALL FLUSH(INPUTFD)
IF (VTYP .EQ. 'S') MN1 = ERROR
RETURN
ENDIF
C
C confirm the request if necessary
C
IF (CONFRM) THEN
IF (.NOT. CONFIRM(INPUTFD)) THEN
IF (VTYP .EQ. 'S') MN1 = ERROR
RETURN
ENDIF
ENDIF
C
C go ahead and set variable
C
IF (VTYP .EQ. 'I') THEN
I = CTOI(STR)
IF (I .GE. MN1 .AND. I .LE. MX1) THEN
VAR(1) = I
ELSE IF (I .GE. MN2 .AND. I .LE. MX2) THEN
VAR(2) = I
ELSE
CALL PRINTL(STDOUT, '? Value is not within range of ')
CALL PUTINT(STDOUT, MN1, 1)
CALL PRINT(STDOUT, '-')
CALL PUTINT(STDOUT, MX1, 1)
CALL PRINT(STDOUT, ', or ')
CALL PUTINT(STDOUT, MN2, 1)
CALL PRINT(STDOUT, '-')
CALL PUTINT(STDOUT, MX2, 1)
ENDIF
ELSE
DO I=1, LEN
VAR(I) = STR(I)
ENDDO
VAR(LEN+1) = 0
MN1 = OK
ENDIF
RETURN
END
SUBROUTINE HELP
IMPLICIT NONE
C
C= Prints help messages
C
INCLUDE 'KVER.INS'
INCLUDE 'KDEF.INS'
C
INTEGER MAXHLPS ;PARAMETER (MAXHLPS = 16)
CHARACTER*10 HLPCMDS(MAXHLPS)
$ /'BYE','CONNECT','EXIT','FINISH','GET','HELP','KERMIT','QUIT',
$ 'RECEIVE','SEND','SERVER','SET','SHOW','STATUS','TAKE','X'/
C
C help send
C
INTEGER LMES10 ;PARAMETER (LMES10 = 5)
CHARACTER*63 MES10 (LMES10)
$ /' ' ,
$ 'SEND local-filename',
$ ' ',
$ 'Sends file to remote KERMIT.',
$ ' '/
C
C help get
C
INTEGER LMES20 ;PARAMETER (LMES20 = 5)
CHARACTER*63 MES20 (LMES20)
$ /' ',
$ 'GET remote-filename',
$ ' ',
$ 'Tells a user Kermit to send a file.',
$ ' '/
C
C help receive
C
INTEGER LMES30 ;PARAMETER (LMES30 = 5)
CHARACTER*63 MES30(LMES30)
$ /' ',
$ 'RECEIVE',
$ ' ',
$ 'Expects one or more files to arrive.',
$ ' '/
C
C help connect
C
INTEGER LMES40 ;PARAMETER (LMES40 = 17)
CHARACTER*63 MES40 (LMES40)
$ /' ',
$ 'CONNECT',
$ ' ',
$ 'Enter terminal emulation mode; presents the illusion of',
$ 'being directly connected as a terminal to the remote',
$ 'system. When escape character is typed, interprets next',
$ 'character as follows:',
$ ' 0 (zero) Transmits a NUL',
$ ' B Transmits a BREAK',
$ ' C Close a connection, return to local KERMIT',
$ ' Q Quit logging (if logging is being done)',
$ ' R Resume logging',
$ ' ? Show available arguments to the escape character',
$ ' (escape character again): Transmit the escape character',
$ ' itself',
$ 'Invalid arguements are beeped and reenters connect mode.',
$ ' '/
C
C help kermit
C
INTEGER LMES50 ;PARAMETER (LMES50 = 19)
CHARACTER*63 MES50(LMES50)
$ /' ',
$ 'Kermit is a file transfer protocol for use over an',
$ 'asynchronous serial telecommunication line. Files are',
$ 'broken up into ""packets"" with checksums and other control',
$ 'information to ensure (with high probability) error-free',
$ 'and complete transmission.',
$ ' ',
$ 'This implementation of Kermit is for the GOULD concept32',
$ 'computers. It may be run remotely using a micro or if',
$ 'the os is MPX3.2B or greater, may be run locally as a',
$ 'terminal emulator',
$ ' ',
$ 'Commands are: SEND, GET, RECEIVE, CONNECT, EXIT, X, QUIT,',
$ 'BYE, FINISH, SERVER, SET, SHOW, STATUS',
$ ' ',
$ 'For further information, type ""HELP"" for any of the above',
$ 'e.g. ""HELP RECEIVE"" or see the Kermit Users Guide and',
$ 'Kermit Protocol manual.',
$ ' '/
C
C help exit, quit, x
C
INTEGER LMES60 ;PARAMETER (LMES60 = 3)
CHARACTER*63 MES60 (LMES60)
$ /' ',
$ 'Exit from Kermit.',
$ ' '/
C
C help take
C
INTEGER LMES70 ;PARAMETER (LMES70 = 5)
CHARACTER*63 MES70 (LMES70)
$ /' ',
$ 'TAKE local-filename',
$ ' ',
$ 'Read and execute Kermit commands from a local file.',
$ ' '/
C
C help server
C
INTEGER LMES90 ;PARAMETER (LMES90=16)
CHARACTER*63 MES90 (LMES90)
$ /' ',
$ 'SERVER',
$ ' ',
$ 'Act as a server for another Kermit. Take all further',
$ 'commands only from the other Kermit. After issuing',
$ 'this command, escape back to your local system and issue',
$ 'SEND or GET, BYE, or other server-oriented',
$ 'commands from there. If your local Kermit does not have',
$ 'a BYE command, it does not have the full ability to',
$ 'communicate with a Kermit server (in which case you can',
$ 'only use the SEND command). If your local Kermit does',
$ 'have a BYE command, use it to shut down and log out',
$ 'the Kermit server when you are done with it; otherwise,',
$ 'connect back to the Gould, type several Control-C''s to',
$ 'stop the server, and logout.',
$ ' '/
C
C help set
C
INTEGER LMES100 ;PARAMETER (LMES100=122)
CHARACTER*63 MES100(LMES100)
$/' ',
$ 'SET',
$ ' ',
$ ' Establish system-dependent parameters. You can examine',
$ 'their values with the SHOW command. Numeric values may be',
$ 'decimal, octal (postfixed with a O), or hexadecimal (post-',
$ 'fixed with an H). The following may be SET:',
$ ' ',
$ ' DEBUG options',
$ ' Show packet traffic explicitly. Options are:',
$ ' ALL Set all debug options.',
$ ' LOG-FILE Log states and packets to the specified file.',
$ ' The default log-file is file L.KERMLOG',
$ ' OFF Don''t display debugging information. (this is',
$ ' the default). If debugging was in effect, turn',
$ ' it off and close any log file.',
$ ' PACKETS Display each incoming and outgoing packet',
$ ' (lengthy)',
$ ' STATES Show kermit state transitions and packet numbers',
$ ' (brief).',
$ ' ',
$ ' LOG options',
$ ' Log all inputs from remote port during connection.',
$ ' Options are:',
$ ' LOG-FILE Log inputs to specified file. The default',
$ ' log-file is file L.SESSION',
$ ' OFF Turn off the session logging',
$ ' ON Turn on the session logging',
$ ' ',
$ ' PORT terminal-address',
$ ' Sets the communicaton port; to which connect, send,',
$ ' receive and server interact with. Any MPX terminal ',
$ ' address may be used. Examples: TY7EC0, U17CC4, or UT.',
$ ' Default is UT',
$ ' ',
$ ' ESCAPE decimal-number',
$ ' Control character used to escape from connect mode.',
$ ' Default is 29, (^])',
$ ' ',
$ ' ECHO on/off',
$ ' Turns on or off the echo by kermit during connect mode.',
$ ' ',
$ ' DELAY decimal-number',
$ ' How many seconds to wait before sending the first',
$ ' packet. This gives you time to ""escape"" back and',
$ ' issue a RECEIVE command.',
$ ' ',
$ ' INIT-RETRY decimal-number',
$ ' Set the maximum number of retries allowed for the',
$ ' initial connection before giving up.',
$ ' ',
$ ' RETRY decimal-number',
$ ' Set the maximum number of retries allowed for sending',
$ ' a particular packet.',
$ ' ',
$ ' SEND parameter',
$ ' Parameters for outgoing packets as follows:',
$ ' ',
$ ' EOLCHR octal-number',
$ ' The octal value of the ASCII character to be used',
$ ' as a line terminator for packets, if one is required',
$ ' by the other system. Carriage return (15B) by default.',
$ ' ',
$ ' PACKLEN decimal-number',
$ ' Maximum packet length to send, decimal number, between',
$ ' 20 and 94, 94 by default.',
$ ' ',
$ ' PADCHR octal-number',
$ ' Character to use for padding. Default is NUL.',
$ ' ',
$ ' PADLEN decimal-number',
$ ' How much padding to send before a packet. Default',
$ ' is no padding.',
$ ' ',
$ ' QUOTECHR octal-number',
$ ' What printable character to use for quoting of control',
$ ' characters. The default is ''#'' (43B). There should',
$ ' be no reason to change this.',
$ ' ',
$ ' SYNCCHR octal-number',
$ ' The control character that marks the beginning of the',
$ ' packet. Normally SOH (Control-A, ASCII 1). There',
$ ' should be no reason to change this.',
$ ' ',
$ ' TIMEOUT decimal-number',
$ ' How many seconds the other Kermit wants before being',
$ ' asked for retransmission.',
$ ' ',
$ ' RECEIVE parameter',
$ ' Parameters to request or expect for incoming packets,',
$ ' as follows:',
$ ' ',
$ ' EOLCHR octal-number',
$ ' The octal value of the ASCII character to be used',
$ ' as a line terminator for packets, if one is required',
$ ' by the other system. Carriage return (15B) by default.',
$ ' ',
$ ' PACKLEN decimal-number',
$ ' Maximum packet length to send, decimal number, between',
$ ' 20 and 94, 94 by default.',
$ ' ',
$ ' PADCHR octal-number',
$ ' Character to use for padding. Default is NUL.',
$ ' ',
$ ' PADLEN decimal-number',
$ ' How much padding to send before a packet. Default',
$ ' is no padding.',
$ ' ',
$ ' QUOTECHR octal-number',
$ ' What printable character to use for quoting of control',
$ ' characters. The default is ''#'' (43B). There should',
$ ' be no reason to change this.',
$ ' ',
$ ' SYNCCHR octal-number',
$ ' The control character that marks the beginning of the',
$ ' packet. Normally SOH (Control-A, ASCII 1). There',
$ ' should be no reason to change this.',
$ ' ',
$ ' TIMEOUT decimal-number',
$ ' How many seconds the other Kermit wants before being',
$ ' asked for retransmission.',
$ ' '/
C
C help show
C
INTEGER LMES110 ;PARAMETER (LMES110= 4 )
CHARACTER*63 MES110(LMES110) !show help
$/' ',
$ 'Display current SET parameters, version of Kermit, and',
$ 'other info.',
$ ' '/
C
C help status
C
INTEGER LMES120 ;PARAMETER (LMES120= 3)
CHARACTER*63 MES120(LMES120)
$/' ',
$ 'Give statistics about the most recent file transfer.',
$ ' '/
C
C help help
C
INTEGER LMES130 ;PARAMETER (LMES130=16)
CHARACTER*63 MES130 (LMES130)
$/' ',
$ 'HELP [topic]',
$ ' ',
$ 'Typing HELP alone prints a brief summary of Kermit',
$ 'and its commands. You can also type',
$ ' ',
$ ' HELP command',
$ ' ',
$ 'for any Kermit command, e.g. ""HELP SEND"", to get more',
$ 'detailed information about a specific command. Type',
$ ' ',
$ ' HELP ?',
$ ' ',
$ 'to see a list of all the available help commands, or',
$ 'consult the Kermit Users Guide.',
$ ' '/
INTEGER LMES140 ;PARAMETER (LMES140 = 6 )
CHARACTER*63 MES140(LMES140)
$ /' ',
$ 'BYE',
$ ' ',
$ 'This command sends a message to the remote server to log',
$ 'itself out',
$ ' '/
INTEGER LMES150 ;PARAMETER (LMES150 = 6 )
CHARACTER*63 MES150 (LMES150)
$/' ',
$ 'FINISH',
$ ' ',
$ 'This command causes the remote server to shut itself down',
$ 'leaving the local KERMIT at KERMIT command level.',
$ ' '/
INTEGER LMES160 ;PARAMETER (LMES160 =3 )
CHARACTER*63 MES160 (LMES160)
$/' ',
$ 'This command is cannot be used on this version of KERMIT.',
$ ' '/
INTEGER IDX !index of code
C
INTEGER MATCH !command parser
C
IDX = MATCH(HLPCMDS,MAXHLPS,.TRUE.)
IF (IDX .EQ. EOF .OR. IDX .EQ. ERROR) RETURN
IF (IDX .EQ. 0) GOTO 50
GOTO ( 140,40, 60, 150,20, 130, 50, 60, 30, 10, 90,
$ 100, 110, 120, 70, 60) IDX
10 CONTINUE !send
CALL OUTTBL(MES10, 1, LMES10)
GOTO 200
20 CONTINUE !get
IF (.NOT. LOCALON) GOTO 160
CALL OUTTBL(MES20, 1, LMES20)
GOTO 200
30 CONTINUE !receive
CALL OUTTBL(MES30, 1, LMES30)
GOTO 200
40 CONTINUE !connect
IF (.NOT. LOCALON) GOTO 160
CALL OUTTBL(MES40, 1, LMES40)
GOTO 200
50 CONTINUE !kermit
CALL OUTTBL(MES50, 1, LMES50)
GOTO 200
60 CONTINUE !exit
CALL OUTTBL(MES60, 1, LMES60)
GOTO 200
70 CONTINUE !take
CALL OUTTBL(MES70, 1, LMES70)
GOTO 200
90 CONTINUE !server
CALL OUTTBL(MES90, 1, LMES90)
GOTO 200
100 CONTINUE !set
CALL OUTTBL(MES100, 1, LMES100)
GOTO 200
110 CONTINUE !show
CALL OUTTBL(MES110, 1, LMES110)
GOTO 200
120 CONTINUE !status
CALL OUTTBL(MES120, 1, LMES120)
GOTO 200
130 CONTINUE !help
CALL OUTTBL(MES130, 1, LMES130)
GOTO 200
140 CONTINUE !bye
IF (.NOT. LOCALON) GOTO 160
CALL OUTTBL(MES140, 1, LMES140)
GOTO 200
150 CONTINUE !finish
IF (.NOT. LOCALON) GOTO 160
CALL OUTTBL(MES150, 1, LMES150)
GOTO 200
160 CONTINUE !no local
CALL OUTTBL(MES160, 1, LMES160)
GOTO 200
200 CONTINUE
RETURN
END
LOGICAL FUNCTION MORE()
IMPLICIT NONE
C
C= Returns true if continue, else false
C
INCLUDE 'KDEF.INS'
C
INTEGER INCHR
C
INTEGER GETC
C
CALL FLUSH(STDIN)
CALL STTY(STDIN, 'READSIZE', 1)
CALL PRINTL(STDOUT, 'Enter CR for more')
MORE = GETC(STDIN, INCHR) .EQ. NEL
CALL STTY(STDIN, 'READSIZE', 80)
RETURN
END
INTEGER FUNCTION RECEIVE(ISTATE)
IMPLICIT NONE
INTEGER ISTATE !state to start at
C
C= Receive a file state switching routine.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
INCLUDE 'KMSG.COM'
C
INTEGER MM,DD,YY, HR, MIN, SEC
INTEGER MSG(MAXPACK)
INTEGER I
C
INTEGER RINIT
INTEGER RDATA
INTEGER RFILE
INTEGER SLEN !length of string
INTEGER ICHAR !character to integer
C
C
C initialize statistics variables
C
CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
STARTIM = HR*3600 + MIN*60 + SEC
SCHCNT = 0
RCHCNT = 0
SCHOVRH = 0
RCHOVRH = 0
TOTSDRC = 0
TOTRTRY = 0
CLT 2.3 ZERO ALL PREVIOUS ABORTS
ABORTYP = .FALSE.
IF (IFD .NE. STDIN) CALL PUTC(STDOUT, NEL)
C
C set packet retry count & current state
C
NUMTRY = 0
STATE = ISTATE
C
C take appropriate action for the current state
C
CALL MONSDRC(STATE)
10 CONTINUE
IF (STATE .EQ. D) THEN
STATE = RDATA()
ELSE IF (STATE .EQ. F) THEN
STATE = RFILE()
ELSE IF (STATE .EQ. R) THEN
STATE = RINIT()
ELSE IF (STATE .EQ. C) THEN
CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
ENDTIM = HR * 3600 + MIN * 60 + SEC
RECEIVE = OK
GOTO 90
ELSE IF (STATE .EQ. A) THEN
CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
ENDTIM = HR * 3600 + MIN * 60 + SEC
RECEIVE = ERROR
IF (FFD .NE. 0) CALL CLOSE(FFD)
CLT 2.3 SHORTEN MESSAGE
CALL GETEMSG(MSG)
CALL SNDPACK(E, PACKNUM, SLEN(MSG), MSG)
GOTO 90
ELSE
CALL PRTMSG(' Receive - state error = ',STATE)
IF (FFD .NE. 0) CALL CLOSE(FFD)
RECEIVE = ERROR
GOTO 90
ENDIF
IF (DEBUG(DBGSTAT)) THEN
CALL PUTC(DBGFD, STATE)
CALL PUTINT(DBGFD, PACKNUM, 1)
CALL PUTC(DBGFD, BLANK)
IF (MOD(PACKNUM+1, 16) .EQ. 0) CALL PUTC(DBGFD, NEL)
ENDIF
GOTO 10
90 CONTINUE !return
CALL MONSDRC(STATE)
RETURN
END
INTEGER FUNCTION RINIT()
IMPLICIT NONE
C
C= Receive a send-init packet
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
C
INTEGER PTYP
INTEGER NUM
C
INTEGER RDPACK
INTEGER SNDPAR
C
IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
NUMTRY = NUMTRY + 1
IF (NUMTRY .GT. MAXRINI) THEN
RINIT = A
ABORTYP(TOOMANY) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(INITERR) = .TRUE.
RETURN
ENDIF
C
C read a packet and hope for best
C
PTYP = RDPACK(LEN, NUM, PACKET)
C
C is it a valid packet type
C
IF (PTYP .EQ. S) THEN
TOTSDRC = TOTSDRC + 1
NUMTRY = 0
CALL MONSDRC(F)
PACKNUM = NUM
CALL RDPARAM(PACKET)
LEN = SNDPAR(PACKET)
CALL SNDPACK(Y, NUM, LEN, PACKET)
PACKNUM = MOD(PACKNUM+1, 64)
RINIT = F
C
C did we get a checksum error
C
ELSE IF (PTYP .EQ. ERROR) THEN
RINIT = STATE
CALL MONSDRC(STATE)
CALL SNDPACK(N, NUM, 0, 0)
ELSE
RINIT = A
ABORTYP(INVALID) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(INITERR) = .TRUE.
ENDIF
RETURN
END
INTEGER FUNCTION RFILE()
IMPLICIT NONE
C
C= Read a filename packet
C
C Rfile expects to see a filename (type f) packet. However it may
C find a send-init retry, end-of-file retry or break packet.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
C
INTEGER PTYP
INTEGER NUM
C
INTEGER RDPACK
INTEGER SNDPAR
INTEGER GETFILE
C
IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
NUMTRY = NUMTRY + 1
IF (NUMTRY .GT. MAXRTRY) THEN
RFILE = A
ABORTYP(TOOMANY) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(FILERR) = .TRUE.
RETURN
ENDIF
C
C read a packet
C
PTYP = RDPACK(LEN, NUM, PACKET)
C
C is it a filename packet?
C
IF (PTYP .EQ. F) THEN
IF (NUM .NE. PACKNUM) THEN
RFILE = A
ABORTYP(SEQERR) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(FILERR) = .TRUE.
RETURN
ENDIF
IF (DEBUG(DBGON)) THEN
CALL PRINTL(DBGFD, 'Receiving file ')
CALL PUTSTR(DBGFD, PACKET)
CALL FLUSH(DBGFD)
ENDIF
FFD = GETFILE(PACKET)
IF (FFD .LE. 0) THEN
FFD = 0
RFILE = A
ABORTYP(LCLFILE) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(FILERR) = .TRUE.
ELSE
NUMTRY = 0
TOTSDRC = TOTSDRC + 1
CALL MONSDRC(D)
CALL STRCPY(PACKET, FILESTR)
CALL SNDPACK(Y, NUM, 0, 0)
PACKNUM = MOD(PACKNUM+1, 64)
RFILE = D
ENDIF
C
C is it an old send-init packet?
C
ELSE IF (PTYP .EQ. S) THEN
IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
NUMTRY = 0
TOTSDRC = TOTSDRC + 1
CALL MONSDRC(STATE)
LEN = SNDPAR(PACKET)
CALL SNDPACK(Y, NUM, LEN, PACKET)
RFILE = STATE
ELSE
RFILE = A
ABORTYP(SEQERR) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(INITERR) = .TRUE.
ENDIF
C
C is it an old eof packet
C
ELSE IF (PTYP .EQ. Z) THEN
IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
NUMTRY = 0
TOTSDRC = TOTSDRC + 1
CALL MONSDRC(STATE)
CALL SNDPACK(Y, NUM, 0, 0)
RFILE = STATE
ELSE
RFILE = A
ABORTYP(SEQERR) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(INITERR) = .TRUE.
ENDIF
C
C is it a break packet?
C
ELSE IF (PTYP .EQ. B) THEN
IF (NUM .NE. PACKNUM) THEN
RFILE = A
ABORTYP(SEQERR) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(BRKERR) = .TRUE.
ELSE
NUMTRY = 0
TOTSDRC = TOTSDRC + 1
CALL MONSDRC(C)
CALL SNDPACK(Y, PACKNUM, 0, 0)
RFILE = C
ENDIF
C
C did we get a checksum error
C
ELSE IF (PTYP .EQ. ERROR) THEN
RFILE = STATE
CALL MONSDRC(STATE)
CALL SNDPACK(N, NUM, 0, 0)
C
C invalid packet type
C
ELSE
RFILE = A
ABORTYP(INVALID) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(FILERR) = .TRUE.
ENDIF
RETURN
END
INTEGER FUNCTION RDATA()
IMPLICIT NONE
C
C= Read a data packet
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
C
C
C check retry count
C
INTEGER PTYP
INTEGER NUM
C
INTEGER RDPACK
C
IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
NUMTRY = NUMTRY + 1
IF (NUMTRY .GT. MAXRTRY) THEN
RDATA = A
ABORTYP(TOOMANY) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(DATAERR) = .TRUE.
RETURN
ENDIF
C
C read a packet
C
PTYP = RDPACK(LEN, NUM, PACKET)
C
C did we get a data packet
C
IF (PTYP .EQ. D) THEN
IF (NUM .NE. PACKNUM) THEN
IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
CALL MONSDRC(STATE)
CALL SNDPACK(Y, NUM, 0, 0)
RDATA = STATE
ELSE
RDATA = A
ABORTYP(SEQERR) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(DATAERR) = .TRUE.
ENDIF
ELSE
TOTSDRC = TOTSDRC + 1
CALL MONSDRC(STATE)
CALL BUFEMP(PACKET, FFD, LEN)
CALL SNDPACK(Y, PACKNUM, 0, 0)
NUMTRY = 0
PACKNUM = MOD(PACKNUM+1, 64)
RDATA = STATE
ENDIF
C
C is it an old filename packet
C
ELSE IF (PTYP .EQ. F) THEN
IF (MOD(NUM+1, 64) .EQ. PACKNUM) THEN
TOTSDRC = TOTSDRC + 1
CALL MONSDRC(STATE)
CALL SNDPACK(Y, NUM, 0, 0)
NUMTRY = 0
RDATA = STATE
ELSE
RDATA = A
ABORTYP(SEQERR) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(FILERR ) = .TRUE.
ENDIF
C
C is it an eof packet
C
ELSE IF (PTYP .EQ. Z) THEN
IF (NUM .NE. PACKNUM) THEN
RDATA = A
ABORTYP(SEQERR) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(EOFERR ) = .TRUE.
ELSE
TOTSDRC = TOTSDRC + 1
CALL MONSDRC(F)
CALL SNDPACK(Y, PACKNUM, 0, 0)
CALL CLOSE(FFD)
FFD = 0
PACKNUM = MOD(PACKNUM+1,64)
NUMTRY = 0
RDATA = F
ENDIF
ELSE IF (PTYP .EQ. ERROR) THEN
RDATA = STATE
CALL MONSDRC(STATE)
CALL SNDPACK(N, NUM, 0, 0)
ELSE
RDATA = A
ABORTYP(INVALID) = .TRUE.
ABORTYP(READING) = .TRUE.
ABORTYP(DATAERR) = .TRUE.
ENDIF
RETURN
END
INTEGER FUNCTION SEND()
IMPLICIT NONE
C
C= Send file state swithcing routine
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
INCLUDE 'KMSG.COM'
C
INTEGER MM,DD,YY, HR, MIN, SEC
INTEGER I
INTEGER MSG(MAXPACK)
C
INTEGER SLEN
INTEGER SDATA
INTEGER SFILE
INTEGER SEOF
INTEGER SBREAK
INTEGER SINIT
INTEGER ICHAR
C
C
C initialize statics variables
C
CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
STARTIM = HR * 3600 + MIN * 60 + SEC
SCHCNT = 0
RCHCNT = 0
SCHOVRH = 0
RCHOVRH = 0
STATE = S
NUMTRY = 0
TOTSDRC = 0
TOTRTRY = 0
CLT 2.3 CLEAR ALL PREVIOUS ABORT MESSAGES
ABORTYP = .FALSE.
IF (IFD .NE. STDIN) CALL PUTC(STDOUT, NEL)
C
C take appropriate action for the current state
C
10 CONTINUE
CALL MONSDRC(STATE)
IF (STATE .EQ. D) THEN
STATE = SDATA()
ELSE IF (STATE .EQ. F) THEN
STATE = SFILE()
ELSE IF (STATE .EQ. Z) THEN
STATE = SEOF()
ELSE IF (STATE .EQ. S) THEN
STATE = SINIT()
ELSE IF (STATE .EQ. B) THEN
STATE = SBREAK()
ELSE IF (STATE .EQ. C) THEN
CALL GETNOW(MM, DD, YY, HR, MIN, SEC)
ENDTIM = HR * 3600 + MIN * 60 + SEC
SEND = OK
GOTO 90
ELSE IF (STATE .EQ. A) THEN
CALL GETNOW(MM,DD,YY,HR,MIN,SEC)
ENDTIM = HR * 3600 + MIN * 60 + SEC
SEND = ERROR
IF (FFD .NE. 0) CALL CLOSE(FFD)
CLT 2.3 SHORTEN ABORT MESSAGE
CALL GETEMSG(MSG)
CALL SNDPACK(E, PACKNUM, SLEN(MSG), MSG)
GOTO 90
ELSE
CALL PRTMSG('Send - state error = ',STATE)
SEND = ERROR
IF (FFD .NE. 0) CALL CLOSE(FFD)
GOTO 90
ENDIF
IF (DEBUG(DBGSTAT)) THEN
CALL PUTC(DBGFD, STATE)
CALL PUTINT(DBGFD, PACKNUM, 1)
CALL PUTC(DBGFD, BLANK)
IF (MOD(PACKNUM+1, 16) .EQ. 0) CALL PUTC(DBGFD, NEL)
ENDIF
GOTO 10
90 CONTINUE
CALL MONSDRC(STATE)
RETURN
END
INTEGER FUNCTION SINIT()
IMPLICIT NONE
C
C= send the send-init packet and wait for reply
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
C
INTEGER PTYP
INTEGER NUM
INTEGER LEN
CHARACTER*16 FILENAM
C
INTEGER OPEN
INTEGER RDPACK
INTEGER SNDPAR
C
IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
NUMTRY = NUMTRY + 1
IF (NUMTRY .GT. MAXRINI) THEN
SINIT = A
ABORTYP(TOOMANY) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(INITERR) = .TRUE.
RETURN
ENDIF
C
C send the send-init packet with the right info
C
LEN = SNDPAR(PACKET)
CALL SNDPACK(S, PACKNUM, LEN, PACKET)
C
C pick up and process reply
C
PTYP = RDPACK(LEN, NUM, RECPACK)
IF (PTYP .EQ. N) THEN
SINIT = STATE
RETURN
ELSE IF (PTYP .EQ. Y) THEN
IF (PACKNUM .NE. NUM) THEN
SINIT = STATE
RETURN
ENDIF
CALL RDPARAM(RECPACK)
TOTSDRC = TOTSDRC + 1
NUMTRY = 0
PACKNUM = MOD(PACKNUM+1,64)
CALL AS2DPC (FILESTR, FILENAM)
CALL FILCHK(FILENAM)
FFD = OPEN(FILENAM, 'R')
CLT 2.3 FLAG UNABLE TO OPEN FILE
IF (FFD .LE. 0) THEN
SINIT = A
ABORTYP(LCLFILE) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(FILERR) = .TRUE.
ELSE
SINIT = F
ENDIF
ELSE IF (PTYP .EQ. ERROR) THEN
SINIT = STATE
ELSE
SINIT = A
ABORTYP(INVALID) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(INITERR) = .TRUE.
ENDIF
RETURN
END
INTEGER FUNCTION SFILE()
IMPLICIT NONE
C
C= Send a filename packet and wait for reply
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
C
INTEGER PTYP
INTEGER NUM
C
INTEGER RDPACK
INTEGER BUFFIL
INTEGER SLEN
C
C
C have we tried this too many times?
C
IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
NUMTRY = NUMTRY + 1
IF (NUMTRY .GT. MAXRTRY) THEN
SFILE = A
ABORTYP (TOOMANY) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(FILERR) = .TRUE.
RETURN
ENDIF
C
C send a filename packet
C
CALL SNDPACK(F, PACKNUM, SLEN(FILESTR), FILESTR)
C
C check on the reply
C
PTYP = RDPACK(LEN, NUM, RECPACK)
IF (PTYP .EQ. N) THEN
IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
SFILE = STATE
RETURN
ELSE
PTYP = Y
NUM = NUM - 1
ENDIF
ENDIF
IF (PTYP .EQ. Y) THEN
IF (PACKNUM .NE. NUM) THEN
SFILE = STATE
RETURN
ENDIF
TOTSDRC = TOTSDRC + 1
NUMTRY = 0
PACKNUM = MOD(PACKNUM+1,64)
C
C get first packet of data from the file
C
PSIZE = BUFFIL(FFD, PACKET)
SFILE = D
ELSE IF (PTYP .EQ. ERROR) THEN
SFILE = STATE
ELSE
SFILE = A
ABORTYP(INVALID) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(FILERR) = .TRUE.
ENDIF
RETURN
END
INTEGER FUNCTION SDATA()
IMPLICIT NONE
C
C= Send a data packet and wait for reply
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
C
INTEGER PTYP
INTEGER NUM
INTEGER LEN
C
INTEGER RDPACK
INTEGER BUFFIL
C
C
C have we tried this too many times
C
IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
NUMTRY = NUMTRY + 1
IF (NUMTRY .GT. MAXRTRY) THEN
SDATA = A
ABORTYP (TOOMANY) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(DATAERR) = .TRUE.
RETURN
ENDIF
C
C send the current data buffer
C
IF (PSIZE .EQ. EOF) THEN
SDATA = Z
RETURN
ENDIF
CALL SNDPACK(D, PACKNUM, PSIZE, PACKET)
C
C check on the reply
C
PTYP = RDPACK(LEN, NUM, RECPACK)
IF (PTYP .EQ. N) THEN
IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
SDATA = STATE
RETURN
ELSE
PTYP = Y
NUM = NUM - 1
ENDIF
ENDIF
IF (PTYP .EQ. Y) THEN
IF (PACKNUM .NE. NUM) THEN
SDATA = STATE
RETURN
ENDIF
TOTSDRC = TOTSDRC + 1
NUMTRY = 0
PACKNUM = MOD (PACKNUM+1,64)
PSIZE = BUFFIL(FFD, PACKET)
IF (PSIZE .EQ. EOF) THEN
SDATA = Z
ELSE
SDATA = STATE
ENDIF
ELSE IF (PTYP .EQ. ERROR) THEN
SDATA = STATE
ELSE
SDATA = A
ABORTYP(INVALID) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(DATAERR) = .TRUE.
ENDIF
RETURN
END
INTEGER FUNCTION SEOF()
IMPLICIT NONE
C
C= Send an eof packet and wait for reply
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
C
INTEGER PTYP
INTEGER NUM
INTEGER LEN
C
INTEGER RDPACK
C
C
C have we tried this too many times
C
IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
NUMTRY = NUMTRY + 1
IF (NUMTRY .GT. MAXRTRY) THEN
SEOF = A
ABORTYP (TOOMANY) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(EOFERR) = .TRUE.
RETURN
ENDIF
C
C send the eof packet
C
CALL SNDPACK(Z, PACKNUM, 0, 0)
C
C check the reply
C
PTYP = RDPACK(LEN, NUM, RECPACK)
IF (PTYP .EQ. N) THEN
IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
SEOF = STATE
RETURN
ELSE
PTYP = Y
NUM = NUM -1
ENDIF
ENDIF
IF (PTYP .EQ. Y) THEN
IF (PACKNUM .NE. NUM) THEN
SEOF = STATE
RETURN
ENDIF
TOTSDRC = TOTSDRC + 1
NUMTRY = 0
PACKNUM = MOD(PACKNUM+1,64)
CALL CLOSE(FFD)
SEOF = B
ELSE IF (PTYP .EQ. ERROR) THEN
SEOF = STATE
ELSE
SEOF = A
ABORTYP(INVALID) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(EOFERR) = .TRUE.
ENDIF
RETURN
END
INTEGER FUNCTION SBREAK()
IMPLICIT NONE
C
C= Send the break packet and wait for reply
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
C
INTEGER PTYP
INTEGER NUM
INTEGER LEN
C
INTEGER RDPACK
C
C
C have we tried this too many times
C
IF (NUMTRY .GT. 0) TOTRTRY = TOTRTRY + 1
NUMTRY = NUMTRY + 1
IF (NUMTRY .GT. MAXRTRY) THEN
SBREAK = A
ABORTYP (TOOMANY) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(BRKERR) = .TRUE.
RETURN
ENDIF
C
C send the break packet
C
CALL SNDPACK(B, PACKNUM, 0, 0)
C
C check on the reply
C
PTYP = RDPACK(LEN, NUM, RECPACK)
IF (PTYP .EQ. N) THEN
IF (MOD(PACKNUM+1,64) .NE. NUM) THEN
SBREAK = STATE
RETURN
ELSE
PTYP = Y
NUM = NUM - 1
ENDIF
ENDIF
IF (PTYP .EQ. Y) THEN
IF (PACKNUM .NE. NUM) THEN
SBREAK = STATE
RETURN
ENDIF
TOTSDRC = TOTSDRC + 1
NUMTRY = 0
PACKNUM = MOD(PACKNUM+1,64)
SBREAK = C
ELSE IF (PTYP .EQ. ERROR) THEN
SBREAK = STATE
ELSE
SBREAK = A
ABORTYP(INVALID) = .TRUE.
ABORTYP(SENDING) = .TRUE.
ABORTYP(BRKERR) = .TRUE.
ENDIF
RETURN
END
SUBROUTINE MONSDRC(ISTATE)
IMPLICIT NONE
INTEGER ISTATE
C
C= Monitor send or receive transaction
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
INCLUDE 'KDBUG.COM'
C
IF (STDIN .NE. IFD) THEN
CALL PUTC(STDOUT, CR)
IF (DEBUG(DBGSTAT)) THEN
CALL PRINT(STDOUT, 'State ')
CALL PUTC(STDOUT, ISTATE)
ENDIF
CALL PRINT(STDOUT, ' Receive ')
CALL PUTINT(STDOUT, TOTSDRC, 3)
CALL PRINT(STDOUT, ' Retry ')
CALL PUTINT(STDOUT, TOTRTRY, 3)
CALL FLUSH(STDOUT)
ENDIF
RETURN
END
SUBROUTINE SNDPACK(TYPE, NUM, LEN, DATA)
IMPLICIT NONE
INTEGER TYPE !type of packet
INTEGER NUM !packet number
INTEGER LEN !length of packet
INTEGER DATA(LEN) !packet to send
C
C= Send a packet down an output stream
C
C Sndpack will send a packet of information and log it
C if debug is turned on. This subroutine could be made
C more efficient by not calling a subroutine for each
C character, but that might cause portability problems.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
INTEGER I
INTEGER CHKSUM ! com puted checksum
INTEGER TMP
INTEGER NCH !number of characters
C
INTEGER TOCHAR
INTEGER CHKSUMER !find checksum
C
IF (DEBUG(DBGPACK)) THEN
CALL PRINTL(DBGFD, 'Sending...')
ENDIF
C
C put out pad chars
C
DO I=1, SPAD
CALL PUTC(OFD, SPADCH)
IF (DEBUG(DBGPACK)) THEN
CALL PUTC(DBGFD, SPADCH)
ENDIF
ENDDO
CALL PUTC(OFD, SNDSYNC)
C
C packet len assumes one character checksums
C
CHKSUM = TOCHAR(LEN+3)
CALL PUTC(OFD, CHKSUM)
TMP = TOCHAR(NUM)
CHKSUM = CHKSUM + TMP
CALL PUTC(OFD, TMP)
CHKSUM = CHKSUM + TYPE
CALL PUTC(OFD, TYPE)
DO I=1, LEN
CHKSUM = CHKSUM + DATA(I)
CALL PUTC(OFD, DATA(I))
ENDDO
CHKSUM = CHKSUMER(CHKSUM)
CALL PUTC(OFD, TOCHAR(CHKSUM))
CALL PUTC(OFD, SPEOL)
IF (DEBUG(DBGPACK)) THEN
CALL PUTC(DBGFD, SNDSYNC)
CALL PUTC(DBGFD, TOCHAR(LEN+3))
CALL PUTC(DBGFD, TOCHAR(NUM))
CALL PUTC(DBGFD, TYPE)
IF (LEN .GT. 0) CALL PUTSTR(DBGFD, DATA)
CALL PUTC(DBGFD, TOCHAR(CHKSUM))
CALL PUTC(DBGFD, SPEOL)
CALL FLUSH(DBGFD)
ENDIF
C
C force buffer flush since desired eol char won't
C
CALL FLUSH(OFD)
C
C update the statistics
C
NCH = SPAD + 5 + LEN + 1
SCHCNT = SCHCNT + NCH
SCHOVRH = SCHOVRH + NCH - LEN
RETURN
END
INTEGER FUNCTION RDPACK(LEN, NUM, DATA)
IMPLICIT NONE
INTEGER LEN !length of packet read
INTEGER NUM !packet number
INTEGER DATA(*) !data read
C
C= Read a packet of information
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
LOGICAL BREAK
COMMON /BREAK/BREAK
C
INTEGER CHKSUM
INTEGER FIELD
INTEGER NCH
INTEGER CH
INTEGER TYPE
INTEGER I
INTEGER STIME !start time
INTEGER FTIME !finish time
C
INTEGER GETC
INTEGER UNCHAR
INTEGER CHKSUMER !compute checksum
C
C debug
C
IF (DEBUG(DBGPACK)) THEN
CALL PRINTL(DBGFD, 'Reading...')
ENDIF
NCH = 0
C
C hunt for start of packet
C
LEN = 0
CHKSUM = 0
CALL MSEC(STIME)
BREAK = .FALSE.
10 CONTINUE
CALL MSEC(FTIME)
IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN
IF (DEBUG(DBGPACK)) THEN
IF (BREAK) THEN
CALL PRINTL(DBGFD, 'BREAK TIMEOUT')
ELSE
CALL PRINTL(DBGFD, 'TIMEOUT')
ENDIF
ENDIF
RDPACK = ERROR
GOTO 30 !RETURN
ENDIF
CH = GETC(IFD, CH)
IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
IF (CH .EQ. ERROR) THEN
GOTO 10
ENDIF
NCH = NCH + 1
CLT IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
IF (CH .NE. SYNC) GOTO 10
C
C parse each field of the packet
C
FIELD = 1
20 CONTINUE
CALL MSEC(FTIME)
IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN
RDPACK = ERROR
GOTO 30 !RETURN
ENDIF
IF (FIELD .LE. 5) THEN
C
C a character read in field 4 here is the first char of the
C data field or the checksum character if the data field is
C empty
C
IF (FIELD .NE. 5 .OR. LEN .GT. 0) THEN
IF (GETC(IFD, CH) .EQ. SYNC) FIELD = 0
NCH = NCH + 1
IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
ENDIF
IF (FIELD .LE. 3) CHKSUM = CHKSUM + CH
C
C if resync
C
IF (FIELD .EQ. 0) THEN
CHKSUM = 0
IF (DEBUG(DBGPACK)) THEN
CALL PRINTL(DBGFD, 'Reading...')
CALL PUTC(DBGFD, SYNC)
ENDIF
C
C if data length
C
ELSE IF (FIELD .EQ. 1) THEN
LEN = UNCHAR(CH-3)
C
C if pack number
C
ELSE IF (FIELD .EQ. 2) THEN
NUM = UNCHAR(CH)
C
C if packet type
C
ELSE IF (FIELD .EQ. 3) THEN
TYPE = CH
C
C if data field is not empty
C
ELSE IF (FIELD .EQ. 4 .AND. LEN .GT. 0) THEN
C
C read 2nd-len chars of data & checksum char
C
DO I=1, LEN
CALL MSEC(FTIME)
IF ((FTIME-STIME)/1000 .GT. TIMEOUT .OR. BREAK) THEN
RDPACK = ERROR
GOTO 30 !RETURN
ENDIF
IF (I .GT. 1) THEN
CH = GETC(IFD, CH)
NCH = NCH + 1
IF (CH .EQ. SYNC) THEN
FIELD = 0
GOTO 20
ENDIF
IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, CH)
ENDIF
CHKSUM = CHKSUM + CH
DATA (I) = CH
ENDDO
C
C if chksum char
C
ELSE IF (FIELD .EQ. 5) THEN
DATA(LEN+1) = 0
CHKSUM = CHKSUMER(CHKSUM)
ENDIF
C
C process next packet field
C
FIELD = FIELD + 1
GOTO 20
ENDIF
IF (DEBUG(DBGPACK)) CALL PUTC(DBGFD, NEL)
C
C does the checksum match
C
IF (CHKSUM .NE. UNCHAR(CH)) THEN
RDPACK = ERROR
RCHOVRH = RCHOVRH + NCH
IF (DEBUG(DBGON)) THEN
CALL PRINTL(DBGFD, 'chksum error, found ')
CALL PUTINT(DBGFD, UNCHAR(CH), 1)
CALL PRINT(DBGFD, ' needed ')
CALL PUTINT(DBGFD, CHKSUM, 1)
ENDIF
ELSE
RDPACK = TYPE
RCHOVRH = RCHOVRH + NCH - LEN
ENDIF
RCHCNT = RCHCNT + NCH
C
C flush any eol characters and other garbage
C
CALL FLUSH(IFD)
30 CONTINUE !error exit
IF (DEBUG(DBGON)) THEN
CALL FLUSH(DBGFD)
ENDIF
RETURN
END
INTEGER FUNCTION BUFFIL(FD, BUFFER)
IMPLICIT NONE
INTEGER FD !file device
INTEGER BUFFER(*) !buffer to fill
C
C= Get some data to send.
C
C BUFFIL READS FROM THE FILE TO SEND AND PERFORMS ALL
C THE PROPER ESCAPING OF CONTROL CHARACTERS AND MAPPING
C NEWLINES INTO CRLF SEQUENCES. IF IT EVER GETS SMART
C ENOUGH, IT WILL ALSO DO THE 8 BIT QUOTING AND REPEAT
C COUNTS.
C
C *** NOTE: THIS ALGORTHM ASSUMES 5 OVERHEAD CHARACTERS FOR THE
C PACKET AND LEAVES 3 CHARACTERS IN CASE THE LAST CHARACTER TO
C BUFFER IS A NEL (EXPANDS TO 4 CHARACTERS).
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
INTEGER I
INTEGER CH
C
INTEGER GETC
INTEGER CTL !control switch
C
C
C get a packet worth of data
C
I = 0
10 CONTINUE
IF (GETC(FD, CH) .NE. EOF) THEN
IF (CH .LT. BLANK .OR. CH .EQ. DEL .OR. CH .EQ. NEL .OR.
$ CH .EQ. SPQUOTE) THEN
IF (CH .EQ. NEL) THEN
BUFFER(I+1) = SPQUOTE
BUFFER(I+2) = CTL(CR)
I = I + 2
CH = LF
ENDIF
I = I + 1
BUFFER(I) = SPQUOTE
IF (CH .NE. SPQUOTE) CH = CTL(CH)
ENDIF
I = I + 1
BUFFER(I) = CH
IF (I .GE. SPKSIZ-8) THEN
BUFFIL = I
GOTO 99
ENDIF
GOTO 10
ENDIF
IF (I .EQ. 0) THEN
BUFFIL = EOF
ELSE
BUFFIL = I
ENDIF
99 CONTINUE
BUFFER(I+1) = 0
RETURN
END
SUBROUTINE BUFEMP( BUFFER, FD, LEN)
IMPLICIT NONE
INTEGER BUFFER(*) !buffer to empty
INTEGER FD !file descriptor
INTEGER LEN !length of buffer to empty
C
C= dumps a buffer to a file
C
INCLUDE 'KDEF.INS'
INCLUDE 'KDBUG.COM'
INCLUDE 'KPROT.COM'
INCLUDE 'KPACK.COM'
C
INTEGER I
INTEGER PREVCH
INTEGER CH
C
INTEGER CTL
C
C
C write the packet data to the file
C
I = 1
10 CONTINUE
IF (I .LE. LEN) THEN
CH = BUFFER(I)
IF (CH .EQ. QUOTECH) THEN
I = I + 1
CH = BUFFER(I)
IF (CH .NE. QUOTECH) CH = CTL(CH)
ENDIF
C
C convert cr/lf pair to NEL
C
IF (CH .EQ. LF .AND. PREVCH .EQ. CR) THEN
CH = NEL
C
C just a lone cr
C
ELSE IF (PREVCH .EQ. CR) THEN
CALL PUTC(FD, PREVCH)
ENDIF
IF (CH .NE. CR) CALL PUTC(FD, CH)
PREVCH = CH
I = I + 1
GOTO 10
ENDIF
RETURN
END
INTEGER FUNCTION CHKSUMER (SUM)
IMPLICIT NONE
INTEGER SUM !sum to find check sum of
C
C= Compute checksum for transmission
C
INTEGER HIGHBITS/X'C0'/ !mask for high bits
INTEGER SHIFTLOW /X'40'/ !make them low bits
INTEGER SIXBITS /X'3F'/ !return only six bits
C
INTEGER IAND !and words together
C
CHKSUMER = IAND (SUM + IAND (SUM,HIGHBITS) / SHIFTLOW,
$ SIXBITS)
RETURN
END
SUBROUTINE AS2DPC(ASTR,DSTR)
IMPLICIT NONE
INTEGER ASTR(100)
CHARACTER*(*) DSTR
C= Translate ascii integer string to character string
C
C ASCII STRING IS TERMINATED BY A ZERO BYTE.
C
C
INTEGER CLEN
INTEGER I
C
CHARACTER*1 CHAR
INTEGER LEN
C
I = 1
CLEN = LEN(DSTR)
DSTR = ' '
10 IF (ASTR(I) .NE. 0 .AND. I .LE. CLEN) THEN
DSTR(I:I) = CHAR(ASTR(I))
I = I + 1
GO TO 10
ENDIF
C
RETURN
END
SUBROUTINE DPC2AS(DSTR,ASTR,N)
IMPLICIT NONE
CHARACTER*(*) DSTR
INTEGER ASTR(200)
INTEGER N
C
C= TRANSLATE STRING OF DISPLAY CODE CHARACTERS ASCII INTEGER STRING.
C STRING IS N CHARACTERS (WORDS) LONG.
C
C
INTEGER I
C
INTEGER ICHAR
C
DO I=1,N
ASTR(I) = ICHAR(DSTR(I:I))
ENDDO
C
C SET ASCII END-OF-STRING-BUFFER
C
ASTR(N+1) = 0
C
RETURN
END
INTEGER FUNCTION CTOI(ASTR)
IMPLICIT NONE
INTEGER ASTR(200)
C= CONVERT CHARACTER BUFFER TO INTEGER.
C
C MC A SUFFIX OF H WILL CONVERT USING BASE 16 AND A SUFFIX
C OF O WILL CONVERT USING BASE 8. DEFAULT SUFFIX IS
C D.
C
INCLUDE 'KDEF.INS'
INTEGER DIG0, DIG7, DIG9, BIGA, BIGB, BIGD
INTEGER BIGF, BIGH, BIGO, LETA, LETB, LETD
INTEGER LETF, LETH, LETO
PARAMETER (DIG0=48, DIG7=55, DIG9=57, BIGA=65, BIGB=66, BIGD=68)
PARAMETER (BIGF=70, BIGH=72, BIGO=79, LETA=97, LETB=98, LETD=100)
PARAMETER (LETF=102, LETH=104, LETO=111)
INTEGER BASE
INTEGER PTR
INTEGER EOD
INTEGER CH
INTEGER TOTAL
INTEGER ISNEG
INTEGER I
BASE = 0
PTR = 0
C
C FIND LAST VALID DIGIT
C
10 PTR = PTR + 1
IF (ASTR(PTR) .NE. 0) GO TO 10
PTR = PTR - 1
IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.
+ ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB .OR.
+ ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN
EOD = PTR - 1
ELSE
EOD = PTR
PTR = PTR + 1
ENDIF
C
C TRY TO FIGURE OUT THE BASE
C
IF (ASTR(PTR) .EQ. 0) THEN
BASE = 10
ELSE IF (ASTR(PTR) .EQ. LETO .OR. ASTR(PTR) .EQ. BIGO .OR.
+ ASTR(PTR) .EQ. LETB .OR. ASTR(PTR) .EQ. BIGB) THEN
BASE = 8
ELSE IF (ASTR(PTR) .EQ. LETH .OR. ASTR(PTR) .EQ. BIGH) THEN
BASE = 16
ENDIF
C
C IF DIDN'T FIND A BASE
C
IF (BASE .EQ. 0) THEN
CALL PRINTL(STDOUT,'CTOI - Invalid base ')
CALL PUTC(STDOUT, ASTR(PTR))
CALL FLUSH(STDOUT)
CTOI = 0
RETURN
ENDIF
C
C ADD UP THE DIGITS
C
TOTAL = 0
ISNEG = 1
DO 100 I = 1,EOD
CH = ASTR(I)
IF (CH .EQ. MINUS) THEN
ISNEG = -1
GO TO 100
ENDIF
IF (BASE .EQ. 10) THEN
IF (CH .LT. DIG0 .OR. CH .GT. DIG9) THEN
CALL PRINTL(STDOUT,'CTOI - Invalid decimal digit ')
CALL PUTC(STDOUT, CH)
CALL FLUSH(STDOUT)
CTOI = 0
RETURN
ELSE
CH = CH - DIG0
ENDIF
ELSE IF (BASE .EQ. 8) THEN
IF (CH .LT. DIG0 .OR. CH .GT. DIG7) THEN
CALL PRINTL(STDOUT,'CTOI - Invalid octal digit ')
CALL PUTC(STDOUT, CH)
CALL FLUSH(STDOUT)
CTOI = 0
RETURN
ELSE
CH = CH - DIG0
ENDIF
ELSE IF (BASE .EQ. 16) THEN
IF (CH .GE. DIG0 .AND. CH .LE. DIG9) THEN
CH = CH - DIG0
ELSE IF (CH .GE. LETA .AND. CH .LE. LETF) THEN
CH = 10 + CH - LETA
ELSE IF (CH .GE. BIGA .AND. CH .LE. BIGF) THEN
CH = 10 + CH - BIGA
ELSE
CALL PRINTL(STDOUT,'CTOI - Invalid hex digit ')
CALL PUTC(STDOUT, CH)
CALL FLUSH(STDOUT)
CTOI = 0
RETURN
ENDIF
ENDIF
TOTAL = TOTAL*BASE + CH
100 CONTINUE
CTOI = TOTAL * ISNEG
RETURN
END
INTEGER FUNCTION ITOS(INT,STR,MINWID)
IMPLICIT NONE
INTEGER INT
INTEGER STR(200)
INTEGER MINWID
CCC ITOS - CONVERT AN INTEGER TO STRING FORMAT.
C
INCLUDE 'KDEF.INS'
INTEGER WIDTH
INTEGER VAL
INTEGER ASCII0
INTEGER TCH
INTEGER IPTR
INTEGER ENDPTR
C
INTEGER MOD
INTEGER ICHAR
WIDTH = 0
IF (INT .LT. 0) THEN
WIDTH = 1
STR(WIDTH) = ICHAR('-')
ENDIF
VAL = IABS(INT)
ASCII0 = ICHAR('0')
10 WIDTH = WIDTH + 1
STR(WIDTH) = MOD(VAL,10) + ASCII0
VAL = VAL / 10
IF (VAL .NE. 0) GO TO 10
STR(WIDTH+1) = 0
C
C NOW REVERSE THE DIGITS
C
IPTR = 1
ENDPTR = WIDTH
IF (STR(IPTR) .EQ. ICHAR('-')) IPTR = IPTR + 1
20 IF (IPTR .LT. ENDPTR) THEN
TCH = STR(IPTR)
STR(IPTR) = STR(ENDPTR)
STR(ENDPTR) = TCH
IPTR = IPTR + 1
ENDPTR = ENDPTR - 1
GO TO 20
ENDIF
ITOS = WIDTH
RETURN
END
INTEGER FUNCTION GETFILE(FN)
IMPLICIT NONE
INTEGER FN(*) !file name
C= Open a file for writing packet data to.
C
C GETFILE WILL TRY TO CREATE A FILE TO WRITE TO. IF IT
C ALREADY EXISTS, THEN IT WILL FAIL.
C
CHARACTER*56 FILENAM
C
INTEGER OPEN
C
INCLUDE 'KDEF.INS'
C
C GET THE DPC VERSION OF THE FILENAME
C
CALL AS2DPC(FN,FILENAM)
CALL FILCHK(FILENAM)
GETFILE = OPEN(FILENAM, 'W')
RETURN
END
SUBROUTINE GETNOW(MM,DD,YY,HR,MIN,SEC)
IMPLICIT NONE
INTEGER MM,DD,YY
INTEGER HR,MIN,SEC
CCC GET THE CURRENT DATE AND TIME.
C
INTEGER IDT(3) !INTEGER DATE AND TIME
C
CALL DATE(IDT)
YY = IDT(1)
MM = IDT(2)
DD = IDT(3)
CALL TIME(IDT)
HR = IDT(1)
MIN = IDT(2)
SEC = IDT(3)
RETURN
END
SUBROUTINE FILCHK(FN)
IMPLICIT NONE
CHARACTER *(*) FN
C
C= Check validity of filename, remove special characters
C
INTEGER PTR,CH
INTEGER I
C
INTEGER LEN
INTEGER ICHAR
CHARACTER*1 CHAR
C
PTR = 1
DO I=1, LEN(FN)
IF (FN(I:I) .EQ. ' ') THEN
ELSE IF(FN(I:I) .GE. 'A' .AND. FN(I:I) .LE. 'Z') THEN
FN(PTR:PTR) = FN(I:I)
PTR = PTR + 1
ELSE IF (FN(I:I) .GE. '0' .AND. FN(I:I) .LE. '9' .AND.
$ I .NE. 1) THEN
FN(PTR:PTR) = FN(I:I)
PTR = PTR + 1
ELSE IF (FN(I:I) .GE. 'a' .AND. FN(I:I) .LE. 'z') THEN
FN(PTR:PTR) = CHAR(ICHAR(FN(I:I)) - X'20')
PTR = PTR + 1
ELSE IF(FN(I:I) .EQ. '.' .OR. FN(I:I) .EQ. '*' .OR.
$ FN(I:I) .EQ. '_') THEN
FN(PTR:PTR) = FN(I:I)
PTR = PTR + 1
ENDIF
ENDDO
IF (PTR .LE. LEN(FN)) FN(PTR:) = ' '
RETURN
END
SUBROUTINE RDPARAM(PDATA)
IMPLICIT NONE
INTEGER PDATA (100)
C= Get the packet parameters from the other kermit
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPACK.COM'
INTEGER PARAMS(11)
EQUIVALENCE (PARAMS,SPKSIZ)
INTEGER I
C
INTEGER CTL
INTEGER UNCHAR
C
C CYCLE THROUGH THE LIST OF PARAMETERS UNTIL THE END-OF-LIST
C IS FOUND (A 0 BYTE).
C Must be loop because variable length reply
C
I = 1
DO WHILE (PDATA(I) .NE. 0 .AND. I .LE. 11)
C
C IS IT THE PAD CHARACTER?
C
IF (I .EQ. 4) THEN
PARAMS(I) = CTL(PDATA(I))
IF (PARAMS(I) .EQ. 0) PARAMS(I) = NULL
C
C IS IT THE QUOTE CHARACTER?
C
ELSE IF (I .EQ. 6) THEN
PARAMS(I) = PDATA(I)
C
C all else
C
ELSE
IF (UNCHAR(PDATA(I)) .NE. 0) THEN
PARAMS(I) = UNCHAR(PDATA(I))
ENDIF
ENDIF
I = I + 1
ENDDO
RETURN
END
SUBROUTINE REMOVE(FN)
IMPLICIT NONE
INTEGER FN(100)
C= Remove a file from the local file list.
C
CHARACTER*56 FNAME
CALL AS2DPC(FN,FNAME)
OPEN(UNIT='TMP',FILE=FNAME)
CLOSE(UNIT='TMP',STATUS='DELETE')
RETURN
END
SUBROUTINE STRCPY(S1,S2)
IMPLICIT NONE
INTEGER S1(200),S2(200)
C= Copy one ascii string to another
C
INTEGER I1
I1 = 1
10 S2(I1) = S1(I1)
IF (S1(I1) .NE. 0) THEN
I1 = I1 + 1
GO TO 10
ENDIF
RETURN
END
INTEGER FUNCTION SLEN(STR)
IMPLICIT NONE
INTEGER STR(200)
C= Return the length of a zero terminated ascii string buffer.
C
INTEGER I
I = 0
10 IF (STR(I+1) .NE. 0) THEN
I = I + 1
GO TO 10
ENDIF
SLEN = I
RETURN
END
INTEGER FUNCTION SNDPAR(PDATA)
IMPLICIT NONE
INTEGER PDATA(100)
C= Setup parameters to send to other kermit.
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPACK.COM'
C
INTEGER I
INTEGER PARAMS(12)
EQUIVALENCE (PARAMS, PACKSIZ)
C
INTEGER CTL
INTEGER TOCHAR
C
C SEND WHAT WE WANT
C
PDATA (1) = TOCHAR(PACKSIZ)
PDATA (2) = TOCHAR(TIMEOUT)
PDATA (3) = TOCHAR(NPAD)
PDATA (4) = CTL(PADCH)
PDATA (5) = TOCHAR(EOLCH)
PDATA (6) = QUOTECH
PDATA (7) = 0
C
C RETURN LENGTH OF HOW MANY THINGS WE WANT TO SET
C
SNDPAR = 6
RETURN
END
SUBROUTINE SLEEP(SECONDS)
IMPLICIT NONE
INTEGER SECONDS
CC
C SLEEP - HOLD FOR <SECONDS> SECONDS.
C
INTEGER I
DO 100 I=1,SECONDS
CALL DELAY(1000)
100 CONTINUE
RETURN
END
SUBROUTINE DELAY(MSEC)
IMPLICIT NONE
INTEGER MSEC
C
C= DELAY - HOLD THINGS UP FOR <MSEC> MILISECS.
C
C **** THIS IS PROBABLY SYSTEM DEPENDENT CODE *****
C IF YOU MODIFY IT USE CONDITIONAL COMPILATION
C
INTEGER IOS
C
CALL WAIT(MSEC, 1, IOS)
RETURN
END
INTEGER FUNCTION CTL (ASCCH)
IMPLICIT NONE
INTEGER ASCCH
C
C= Flip control bit protecting control chars and unprotecting
C
CTL = IEOR(ASCCH,X'40')
RETURN
END
INTEGER FUNCTION TOCHAR(ASCCH)
IMPLICIT NONE
INTEGER ASCCH
C
C= Make an ascii character.
C
INCLUDE 'KDEF.INS'
C
TOCHAR = ASCCH + BLANK
RETURN
END
INTEGER FUNCTION UNCHAR(ASCCH)
IMPLICIT NONE
INTEGER ASCCH
C
C= Convert back to control character
C
INCLUDE 'KDEF.INS'
C
UNCHAR = ASCCH - BLANK
RETURN
END
SUBROUTINE GETMACH(MACH)
IMPLICIT NONE
CHARACTER*(*) MACH !current machine type
C
C= Retrieves current machine type from os
C
CHARACTER*2 MACHS(0:5) !gould machines
$ /'55','75','27','67','87','97'/
INTEGER IMACH !read machine type
C
INLINE
LB 7,X'0CBF' !get machine type code
STW 7,IMACH !store for use
ENDI
IF (IMACH .GE. 0 .AND. IMACH .LE. 5) THEN
MACH = MACHS(IMACH)
ELSE
MACH = '**'
ENDIF
RETURN
END
SUBROUTINE PRTMSG(STR, VAL)
IMPLICIT NONE
CHARACTER*(*) STR
INTEGER VAL
C
C= Prints a message to output device (normally abort message)
C
1000 FORMAT (X,A,I4)
WRITE ('UT',1000,ERR=10) STR, VAL
10 CONTINUE
RETURN
END
SUBROUTINE DISPLAY (S)
IMPLICIT NONE
CHARACTER*(*) S
C
C= Display string on console
C
INTEGER WORD
CHARACTER*80 STRING
EQUIVALENCE (WORD, STRING) !word bound string
C
STRING = S
CALL CARRIAGE
CALL M:TELEW(STRING)
RETURN
END
INTEGER FUNCTION NOFIND (STRING,CHARN)
IMPLICIT NONE
C= Return position of 1st character in STRING that does not match CHARN.
C
C RETURN THE INDEX OF THE FIRST
C CHARACTER IN STRING THAT DOES
C NOT MATCH CHARN.
C RETURNS 0 IF THE STRINGS MATCH.
C
C FORMAL PARAMETER DECLARATIONS.
CHARACTER*(*) STRING,CHARN
C
C LOCAL DECLARATIONS.
C
C LENGTH OF STRING PARAMETER.
INTEGER STRLEN
C STRING SEARCH POINTER.
INTEGER I
C LENGTH OF STRING FUNCTION
INTRINSIC LEN
C
C-------------------------------------------------------------------
C
C FIND LENGTH OF INPUT STRING.
STRLEN = LEN(STRING)
C PRESET FUNCTION VALUE TO INDICATE
C SEARCH FAILED TO FIND NON-CHARN
C CHARACTER.
NOFIND = 0
C INITIALIZE STRING SEARCH POINTER.
I=0
10 CONTINUE
C POINT TO NEXT CHARACTER IN STRING
I = I + 1
C BEYOND END OF STRING - SEARCH FAILED.
IF( I .GT. STRLEN ) GO TO 20
C DO IT AGAIN IF THIS CHARACTER MATCHES.
IF( STRING(I:I) .EQ. CHARN ) GO TO 10
C MISMATCH ENCOUNTERED - NOTE
C POSITION AND RETURN.
NOFIND = I
C
20 CONTINUE
C
RETURN
END
INTEGER FUNCTION LASTCHR (STRING)
IMPLICIT NONE
C= Return position of last non-blank character in STRING.
C
C FIND THE LAST NON-BLANK CHARACTER
C IN THE INPUT STRING.
C
C
CHARACTER*(*) STRING ! GIVEN STRING
C
C RETURNS LASTCHR ! POSITION OF LAST NON-BLANK CHARACTER
C IN STRING
C
INTEGER CHR
C
INTEGER LEN
INTRINSIC LEN
C
INTEGER ZERO,ONE
PARAMETER (ZERO=0,ONE=1)
C CHARACTER*1 BLANK
C PARAMETER (BLANK=' ')
C
C REVISED 12/08/82, PDM. CORRECT TREATMENT OF EMPTY LINE.
C
C------------------------------------------------------------------
C
C
CHR = LEN(STRING) + ONE
10 CONTINUE
CHR = CHR - ONE
IF (CHR.LE.ZERO) GOTO 20
IF (STRING(CHR:CHR).EQ.' ') GOTO 10
20 CONTINUE
C
LASTCHR = CHR
C
C
RETURN
END
SUBROUTINE LADJ(STRING)
IMPLICIT NONE
C= Left-justify a string.
C Left-justify a string.
C-------------------------------------------------------------------
C Written May 6, 1983 by Fred Preller, Simulation Associates, Inc.
C-------------------------------------------------------------------
CHARACTER*(*) STRING
C-------------------------------------------------------------------
INTEGER FIRST ! First non-blank character position
CHARACTER*1 BLANK/' '/
C-------------------------------------------------------------------
INTEGER NOFIND
EXTERNAL NOFIND
C-------------------------------------------------------------------
FIRST = NOFIND(STRING,BLANK)
C Note the criteria: FIRST = 0 => totally blank line, and
C FIRST = 1 => line already justified.
IF( FIRST .GT. 1 ) STRING = STRING(FIRST:)
RETURN
END
SUBROUTINE BREAKR
IMPLICIT NONE
C= Establish break receiver
C
C BREAKR ESTABLISHES A BREAK RECEIVER THAT REMAINS ACTIVE AS
C LONG AS THE TASK IS ACTIVE. WHEN A BREAK IS RECEIVED, THE
C BREAK FLAG IS SET. THE USER MUST CLEAR THE FLAG TO ENSURE
C THAT SUBSEQUENT BREAKS ARE DETECTED.
C
LOGICAL BREAK
COMMON /BREAK/ BREAK
C
CALL X:BRK ($100,,)
BREAK = .FALSE.
RETURN
C
C BREAK ENTRY POINT
100 BREAK = .TRUE.
CALL X:BRKXIT
C
END
SUBROUTINE SLINE(S)
CHARACTER*(*) S !tsm line
C
C= Returns the tsm command line without the execution portion
C
CHARACTER*236 BUFF !local buffer
INTEGER NRESV !number of reserved words
PARAMETER (NRESV = 5)
CHARACTER*8 RWORDS(NRESV) !reserved pre words
$ /'RUN', 'EXECUTE ', 'EXEC', 'DEBU', 'DEBUG'/
CHARACTER*8 R !reserved word
INTEGER OUT/'OUT'/
CHARACTER*1 D !delimitor
C
C SLINE
C
CALL TLINE(BUFF) !get tsm command line
CALL LADJ(BUFF)
C
C remove leading '$'
C
IF (BUFF(1:1) .EQ. '$') THEN
BUFF = BUFF(2:)
END IF
CALL EXTR(R, D, BUFF) !possible task name/reserved
C
C get rid of leading reserved words
C
DO 20,I=1, NRESV
IF (R .EQ. RWORDS(I)) THEN
CALL EXTR(R, D, BUFF) !get task path
LEAVE 20
END IF
20 END DO
C
C check for dsc name
C
IF (R(1:1) .EQ. '@' .OR. R(1:1) .EQ. '^' .OR. D .EQ. '(') THEN
CALL EXTR(R, D, BUFF) !extract directory
CALL EXTR(R, D, BUFF) !task name
END IF
C
C return remander without task name
C
S = BUFF
RETURN
END
SUBROUTINE EXTR(R, D, S)
CHARACTER*(*) R !extracted word
CHARACTER*1 D !delimitor
CHARACTER*(*) S !word to extract from
C
C= Extracts the next word based on TSM's delimitors
C
CHARACTER*9 DELIM /' ,()=;$!%'/ !delimitors
CHARACTER*2 QUOTES /'''""'/ !quotes
INTEGER NS !length of S
INTEGER I
LOGICAL QUOTE !in quote
CHARACTER*1 QUOTECH !character used in quote
C
C functions
C
INTEGER NOFIND !look until not found
C
C extr
C
QUOTE = .FALSE.
NS = LEN(S)
I = 1
DO 20, WHILE (I .LE. NS)
IF (QUOTE) THEN
IF (S(I:I) .EQ. QUOTECH) THEN
QUOTE = .FALSE.
ENDIF
ELSE
IF (INDEX(QUOTES, S(I:I)) .GT. 0) THEN
QUOTECH = S(I:I)
QUOTE = .TRUE.
ELSE IF (INDEX(DELIM, S(I:I)) .GT. 0) THEN
LEAVE 20
ENDIF
END IF
I = I + 1
20 END DO
C
C returned field
C
IF (I .GT. NS) THEN
R = S
ELSE IF (I .EQ. 1) THEN
R = ' '
ELSE
R = S(:I-1)
END IF
C
C delimitor
C
IF (I .GT. NS) THEN
D = ' '
ELSE
D = S(I:I)
END IF
C
C new buffer
C
IF (I .GT. NS) THEN
S = ' '
ELSE IF (I .EQ. NS) THEN
S = ' '
ELSE
S = S(I+1:)
END IF
C
C remove trailing blanks
C
I = NOFIND(S, ' ')
IF (I .GT. 0) S = S(I:)
RETURN
END
LOGICAL FUNCTION ISFILE(PATHNAME)
IMPLICIT NONE
CHARACTER*(*)PATHNAME !PATH TO CHECK
C
C= Tests to determine if file specified in path exists
C
INTEGER*4 RDBUFFER(8) !RESOURCE DESCR. BUFFER
INTEGER*4 ERRSTAT !ERROR STATUS
C
C
CALL X_RID(PATHNAME,RDBUFFER,ERRSTAT)
ISFILE = ERRSTAT .EQ. 0
RETURN
END
INTEGER FUNCTION XTOI(S)
IMPLICIT NONE
CHARACTER*(*) S !hex number in ascii
C return integer value
C
C= Converts an ascii hex string to integer number
C
INTEGER N !length of string
INTEGER I !string pointer
INTEGER C !ascii value
INTEGER ZERO/X'30'/ !ascii zero
INTEGER NINE/X'39'/
INTEGER A /X'41'/
INTEGER F /X'46'/
C
C functions
C
INTEGER ICHAR !char to integer value
INTEGER LEN !length of string
C
C xtoi
C
N = LEN(S)
I = 1
XTOI = 0
DO WHILE (I .LT. N .AND. S(I:I) .EQ. ' ')
I = I + 1
END DO
DO 20 WHILE (I .LE. N)
C = ICHAR(S(I:I))
IF (C .GE. ZERO .AND. C .LE. NINE) THEN
C = C - ZERO
ELSE IF (C .GE. A .AND. C .LE. F) THEN
C = C - A + 10
ELSE
LEAVE 20
END IF
INLINE
LW 6,XTOI !get previous value
LW 7,C !get current value to add
SLL 7,28 !left justify
SLLD 6,4 !move into xtoi
STW 6,XTOI !done
ENDI
I = I + 1
20 END DO
RETURN
END
CHARACTER*(*) FUNCTION ITOX (X)
IMPLICIT NONE
INTEGER X !hex value
C
C= Convert integer to hex ascii string
C forces a leading numeric character
C
CHARACTER*9 T !temporary string
INTEGER I !sting pointer
INTEGER J !local value to convert
INTEGER C !convertion value
INTEGER A/X'41'/
INTEGER F/X'46'/
INTEGER ZERO/X'30'/
INTEGER NINE/X'39'/
C
C functions
C
CHARACTER*1 CHAR !integer to character function
C
C ITOX
C
J = X
T = ' '
I = 9
DO UNTIL (J .EQ. 0)
INLINE
LW 6,J !get current value
SRLD 6,4 !get first hex value
SRL 7,28 !right justify
STW 7,C !convert
STW 6,J !new value
ENDI
IF (C .GE. 10) THEN
C = C - 10 + A
ELSE
C = C + ZERO
END IF
T(I:I) = CHAR(C)
I = I - 1
END DO
IF (T(I+1:I+1) .GT. 'A') THEN
T(I:I) = CHAR(ZERO)
END IF
CALL LADJ(T)
ITOX = T
RETURN
END
CHARACTER*(*) FUNCTION ITOA (I)
IMPLICIT NONE
INTEGER I !integer to output
C
C= Converts an integer number to an ascii string
C
CHARACTER*20 BUF !local buffer
INTEGER J !local integer value
C
C format
C
1000 FORMAT (I20)
C
C itoa
C
J = I
WRITE (BUF, 1000, ERR=10) J
CALL LADJ(BUF)
ITOA = BUF
RETURN
10 CONTINUE
ITOA = '0'
RETURN
END
SUBROUTINE GETEMSG(STRNG)
IMPLICIT NONE
INTEGER STRNG(200)
C
C= Produce an error message string for the current error
CLT 2.3 THIS ROUTINE TRW'D TO PRODUCE CORRECT ERROR MESSAGES
C
INCLUDE 'KDEF.INS'
INCLUDE 'KPROT.COM'
C
INTEGER I
C
I = 1
IF (ABORTYP(SENDING)) THEN
CALL DPC2AS('SENDING',STRNG(I), 7)
I = I + 7
ELSE
CALL DPC2AS('RECEIVING',STRNG(I),9)
I = I + 9
ENDIF
IF (ABORTYP(INITERR)) THEN
CALL DPC2AS(' INIT',STRNG(I),5)
I = I + 5
ELSE IF (ABORTYP(FILERR)) THEN
CALL DPC2AS(' FILE NAME',STRNG(I),10)
I = I + 10
ELSE IF (ABORTYP(DATAERR)) THEN
CALL DPC2AS(' DATA',STRNG(I),5)
I = I + 5
ELSE IF (ABORTYP(EOFERR)) THEN
CALL DPC2AS(' EOF',STRNG(I),4)
I = I + 4
ELSE
CALL DPC2AS(' BREAK',STRNG(I),6)
I = I + 6
ENDIF
CALL DPC2AS(' PACKET,',STRNG(I),7)
I = I + 7
IF (ABORTYP(TOOMANY)) THEN
CALL DPC2AS(' TOO MANY RETRIES',STRNG(I),17)
I = I + 17
ELSE IF (ABORTYP(INVALID)) THEN
CALL DPC2AS(' RECV. INVALID PACKET',STRNG(I),20)
I = I + 20
ELSE IF (ABORTYP(SEQERR)) THEN
CALL DPC2AS(' RECV. OUT OF SEQ. PACKET',STRNG(I),25)
I = I + 25
ELSE IF (ABORTYP(LCLFILE)) THEN
CALL DPC2AS(' FAILED TO OPEN FILE',STRNG(I), 21)
I = I + 21
ELSE
CALL DPC2AS(' UNANTICIPATED ERROR',STRNG(I),20)
I = I + 20
ENDIF
STRNG(I) = 0
I = I+1
RETURN
END
BLOCK DATA BDFILECO
IMPLICIT NONE
C
C= Initialize the filecom common
C
INCLUDE 'KFILE.COM'
C
DATA FMODE/MAXFILE*CLOSED/ !close all units
DATA FCHPTR /MAXFILE*0/
DATA FCHCNT /MAXFILE*0/
DATA FEOF /MAXFILE*.FALSE./
DATA CTDEV /MAXFILE*.FALSE./
DATA FREQ /MAXFILE*0/
DATA IOPEND /MAXFILE*NOIO/
DATA NOWAIT /MAXFILE*.FALSE./
DATA BINARY /MAXFILE*.FALSE./
DATA FTIMOUT/MAXFILE* 0/
END
INTEGER FUNCTION OPEN(FN, MODE)
IMPLICIT NONE
CHARACTER*(*) FN !file name
CHARACTER*(*) MODE !mode of file ('R','W')
C
C= o Opens a file as specified, returns file index
INCLUDE 'KFILE.COM'
C
INTEGER I !indexing
CHARACTER*8 FILESTAT !file status for open
INTEGER IOS !status of open
INTEGER IMODE !translated mode code
INTEGER ALTLFC !altlfc to assign to
CHARACTER*4 CALTLFC !character form of alt lfc
EQUIVALENCE (CALTLFC, ALTLFC)
CHARACTER*1 OPENMODE !access mode
C
INTEGER ICHAR !character to integer
C
IF (MODE .EQ. 'R') THEN
IMODE = RD
ELSE IF (MODE .EQ. 'W' .OR. MODE .EQ. 'C') THEN
IMODE = WR
ELSE
CALL PRTMSG('OPEN - invalid mode',ICHAR(MODE))
OPEN = ERROR
RETURN
ENDIF
DO I=1, MAXFILE !handle duplicates
C
C handle duplicate entries
C
IF (FMODE(I) .NE. CLOSED) THEN !if open
IF (FNAME(I) .EQ. FN) THEN !if duplicate
IF (FMODE(I) .EQ. IMODE) THEN !if same mode, ignore
IF (CTDEV(I)) THEN !if device, flush, ready
CALL FLUSH(I)
OPEN = I
RETURN
ELSE !if file, rewind
CALL FLUSH(I)
CALL CLOSE(I)
ENDIF
ELSE !if mode different, reopen
IF (CTDEV(I)) THEN !if device, not really dupl.
CONTINUE
ELSE !if file, close so can reopen
CALL FLUSH(I)
CALL CLOSE(I)
ENDIF
ENDIF
ENDIF
ENDIF
ENDDO
C
C find slot
C
OPEN = 1
DO WHILE (OPEN .LT. MAXFILE .AND. FMODE(OPEN) .NE. CLOSED)
OPEN = OPEN + 1
ENDDO
IF (FMODE(OPEN) .NE. CLOSED) THEN
OPEN = ERROR
CALL PRTMSG('OPEN - Exceed allowed number of files',MAXFILE)
RETURN
ENDIF
C
C open
C
FNAME(OPEN) = FN
FCHPTR(OPEN) = 1
FCHCNT(OPEN) = 0
FMODE(OPEN) = IMODE
FEOF(OPEN) = .FALSE.
CTDEV(OPEN) = .FALSE.
FREQ(OPEN) = MAXCH
IOPEND(OPEN) = NOIO
NOWAIT(OPEN) = .FALSE.
FTIMOUT(OPEN) = 0
BINARY(OPEN) = .FALSE.
DO I=1, 4
FBLK(I, OPEN) = 0
ENDDO
DO I=1, MAXCH
FCHBUF(I, OPEN) = 0
ENDDO
C
C if standard i/o, connect to user terminal
C
IF (FNAME(OPEN) .EQ. 'STDIN' .OR. FNAME(OPEN) .EQ. 'STDOUT') THEN
OPEN (UNIT=OPEN, ALTUNIT='UT', IOSTAT=IOS, ERR=910)
CTDEV(OPEN) = .TRUE.
FREQ(OPEN) = 133
C
C if terminal - all terminals begin with @
C
ELSE IF (FNAME(OPEN)(1:1) .EQ. '@') THEN
FNAME(OPEN) = FNAME(OPEN)(2:)
OPEN (UNIT=OPEN, DEVICE=FNAME(OPEN),
$ WAIT=.FALSE.,
$ IOSTAT=IOS, ERR=910)
CTDEV(OPEN) = .TRUE.
FREQ(OPEN) = 133
C
C must be file
C
ELSE
IF (FMODE(OPEN) .EQ. RD) THEN
FILESTAT='OLD'
OPENMODE = 'R'
ELSE
FILESTAT='UNKNOWN'
OPENMODE = 'U'
ENDIF
OPEN(UNIT=OPEN, FILE=FNAME(OPEN),
$ BLOCKED=.TRUE., FORM='FORMATTED',
$ WAIT=.FALSE.,STATUS=FILESTAT,
$ OPENMODE = OPENMODE,
$ IOSTAT=IOS, ERR=910)
ENDIF
CALL BLKINIT(OPEN)
RETURN
C
C open error
C
910 CONTINUE
FMODE(OPEN) = CLOSED
OPEN = -IOS
RETURN
END
SUBROUTINE BLKINIT(FD)
IMPLICIT NONE
INTEGER FD !file descriptor
C
C= Calls fcbinit with proper function code for current flags
C
INCLUDE 'KFILE.COM'
C
INTEGER FUNC !function code
INTEGER NOWAITW/X'80000000'/ !nowait operation
INTEGER DFI /X'20000000'/ !use io spec we specify
INTEGER XXWORD /X'00100000'/ !xon/xoff protocol
INTEGER EXP /X'02000000'/ !expanded fcb
INTEGER NOERR /X'40000000'/ !no error branch
INTEGER CONTROL/X'00800000'/ !control character detect
INTEGER NOECHO /X'00400000'/ !do not echo down port
INTEGER NOUPPER/X'00200000'/ !do not convert to upper case
INTEGER SPCHRW /X'00100000'/ !special character detect
INTEGER PURGEW /X'00080000'/ !purge type ahead buffer
C
IF (CTDEV(FD)) THEN
IF (FMODE(FD) .EQ. RD) THEN
IF (BINARY(FD)) THEN
FUNC = NOERR + EXP + DFI + CONTROL + NOECHO + NOUPPER
ELSE
FUNC = NOERR + EXP
ENDIF
ELSE !write
FUNC = NOERR + EXP + DFI
ENDIF
ELSE !disk read/write
FUNC = NOERR + EXP
ENDIF
IF (NOWAIT(FD)) FUNC = FUNC + NOWAITW
CALL FCBINIT(FD, FBLK(1, FD), FUNC, FREQ(FD))
RETURN
END
SUBROUTINE CLOSE(FD)
IMPLICIT NONE
INTEGER FD !file descriptor
C
C= Closes an opened file.
C
INCLUDE 'KFILE.COM'
C
IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
CONTINUE !ignore errors
ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
CONTINUE !already closed
ELSE
CALL FLUSH(FD)
CLOSE(UNIT=FD)
FMODE(FD) = CLOSED
ENDIF
RETURN
END
SUBROUTINE FLUSH(FD)
IMPLICIT NONE
INTEGER FD !file descriptor
C
C= forces output of buffer
C
INCLUDE 'KFILE.COM'
C
INTEGER*1 LBUF(MAXCH, MAXFILE) !local buffers for nowait
INTEGER I
C
IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
RETURN
ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
RETURN
ELSE
IF (FMODE(FD) .EQ. WR .AND. FCHCNT(FD) .GT. 0) THEN
IF (IOPEND(FD) .EQ. NOIO) THEN
IF (NOWAIT(FD)) THEN
IOPEND(FD) = IOSTART
DO I=1, FCHCNT(FD)
LBUF(I, FD) = FCHBUF(I, FD)
ENDDO
GOTO (10,20,30,40,50,60,70,80,90,100) FD
10 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *801, *801)
GOTO 150
20 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *802, *802)
GOTO 150
30 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *803, *803)
GOTO 150
40 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *804, *804)
GOTO 150
50 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *805, *805)
GOTO 150
60 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *806, *806)
GOTO 150
70 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *807, *807)
GOTO 150
80 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *808, *808)
GOTO 150
90 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *809, *809)
GOTO 150
100 CONTINUE
CALL DPWRITE(FBLK(1, FD), LBUF(1,FD), FCHCNT(FD), 0,
$ *810, *810)
GOTO 150
150 CONTINUE
ELSE
IOPEND(FD) = NOIO
CALL DPWRITE(FBLK(1, FD), FCHBUF(1, FD), FCHCNT(FD), 0)
ENDIF
ENDIF
ELSE IF (FMODE(FD) .EQ. RD .AND. IOPEND(FD) .EQ. IOSTART) THEN
CALL HIO(FD)
CLT DO I=1, MAXFILE
CLT IF (FMODE(I) .EQ. WR .AND. IOPEND(I) .EQ. IOSTART)
CLT $ CALL X:EAWAIT(0,,)
CLT IF (IOPEND(I) .EQ. IOSTART) IOPEND(I) = NOIO
CLT ENDDO
CLT CALL HIOALL !this is going to hurt somewhere
ENDIF
FCHPTR(FD) = 1
FCHCNT(FD) = 0
ENDIF
RETURN
C
C end action
C
801 IOPEND( 1) = NOIO; CALL X:XNWIO
802 IOPEND( 2) = NOIO; CALL X:XNWIO
803 IOPEND( 3) = NOIO; CALL X:XNWIO
804 IOPEND( 4) = NOIO; CALL X:XNWIO
805 IOPEND( 5) = NOIO; CALL X:XNWIO
806 IOPEND( 6) = NOIO; CALL X:XNWIO
807 IOPEND( 7) = NOIO; CALL X:XNWIO
808 IOPEND( 8) = NOIO; CALL X:XNWIO
809 IOPEND( 9) = NOIO; CALL X:XNWIO
810 IOPEND(10) = NOIO; CALL X:XNWIO
END
SUBROUTINE PUTC(FD, TCH)
IMPLICIT NONE
INTEGER FD !file descriptor
INTEGER TCH !character to output
C
C= outputs a character
C
C **** NOTE: tricky stuff, no difference between terminal
C outputs in binary or ascii, but in binary NEL's are
C not interpreted. So don't put term in binary unless
C you really mean it.
C
C
INCLUDE 'KFILE.COM'
C
INTEGER CH
INTEGER I
C
IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
CONTINUE
ELSE IF (FMODE(FD) .EQ. WR) THEN
CH = TCH
IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN
CH = CR
IF (.NOT. CTDEV(FD)) GOTO 20
ENDIF
10 CONTINUE
IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD)
IF (FCHCNT(FD) .LT. MAXCH) THEN
FCHCNT(FD) = FCHCNT(FD) + 1
FCHBUF(FCHCNT(FD), FD) = CH
ENDIF
IF (FCHCNT(FD) .GE. FREQ(FD)) CALL FLUSH(FD)
IF (TCH .EQ. NEL .AND. CH .EQ. CR) THEN
CH = LF
GOTO 10
ENDIF
20 CONTINUE
C
C end of line processing
C
IF (.NOT. BINARY(FD) .AND. TCH .EQ. NEL) THEN
C
C if text file, strip trailing blanks, cr, lf
C
IF (.NOT. CTDEV(FD)) THEN
I = FCHCNT(FD)
DO WHILE (I .GT. 0)
IF (FCHBUF(I, FD) .EQ. BLANK .OR. FCHBUF(I, FD) .EQ.
$ CR .OR. FCHBUF(I, FD) .EQ. LF) THEN
I = I - 1
ELSE
LEAVE
ENDIF
ENDDO
IF (I .LE. 0) THEN
I = I + 1
FCHBUF(I, FD) = BLANK
ENDIF
FCHCNT(FD) = I
ENDIF
CALL FLUSH(FD) !force out
ENDIF
ENDIF
RETURN
END
INTEGER FUNCTION GETC(FD, CH)
IMPLICIT NONE
INTEGER FD !file descriptor
INTEGER CH !character read in
C
C= Reads a character from input buffer, reads if necessary
C
INCLUDE 'KFILE.COM'
C
IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
CH = ERROR
ELSE IF (FMODE(FD) .EQ. RD) THEN
IF (FCHPTR(FD) .GT. FCHCNT(FD)) CALL FILL(FD)
IF (FEOF(FD)) THEN
CH = EOF
ELSE IF (FCHPTR(FD) .GT. FCHCNT(FD)) THEN
CH = ERROR
ELSE
CH = FCHBUF(FCHPTR(FD), FD)
FCHPTR(FD) = FCHPTR(FD) + 1
ENDIF
ELSE
CH = ERROR
ENDIF
GETC = CH
RETURN
END
SUBROUTINE FILL(FD)
IMPLICIT NONE
INTEGER FD !file descriptor
C
C= Fills the respective fd's buffer
C
INCLUDE 'KFILE.COM'
C
INTEGER STATUS !status of io done
INTEGER I !temp count
C
INTEGER DPCOUNT !retreive count of transfer
INTEGER DERROR !error code
C
IF (IOPEND(FD) .EQ. NOIO) THEN
IF (NOWAIT(FD)) THEN
IOPEND(FD) = IOSTART
GOTO (10, 20, 30, 40, 50, 60, 70, 80, 90, 100) FD
10 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*801,*801)
GOTO 150
20 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*802,*802)
GOTO 150
30 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*803,*803)
GOTO 150
40 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*804,*804)
GOTO 150
50 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*805,*805)
GOTO 150
60 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*806,*806)
GOTO 150
70 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*807,*807)
GOTO 150
80 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*808,*808)
GOTO 150
90 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*809,*809)
GOTO 150
100 CONTINUE
CALL DPREAD(FBLK(1,FD),FCHBUF(1,FD),FREQ(FD), 0,*810,*810)
GOTO 150
150 CONTINUE
IF (FTIMOUT(FD) .GT. 0) THEN
CALL X:EAWAIT(-FTIMOUT(FD)*20,,)
IF (IOPEND(FD) .EQ. IOSTART) THEN
CALL HIO(FD)
CALL X:EAWAIT(-FTIMOUT(FD)*20,,)
ENDIF
ENDIF
ELSE
CALL DPREAD(FBLK(1, FD), FCHBUF(1, FD), FREQ(FD), 0)
IOPEND(FD) = IOCOMP
ENDIF
ENDIF
IF (IOPEND(FD) .EQ. IOCOMP) THEN
IOPEND(FD) = NOIO
FCHPTR(FD) =1
FCHCNT(FD) = DPCOUNT(FBLK(1, FD))
IF (.NOT. BINARY(FD)) THEN
IF (CTDEV(FD)) THEN
FCHCNT(FD) = FCHCNT(FD) + 1
FCHBUF(FCHCNT(FD), FD) = NEL
ELSE
I = FCHCNT(FD)
DO WHILE (I .GT. 0)
IF (FCHBUF(I,FD) .EQ. BLANK) THEN
I = I - 1
ELSE
LEAVE
ENDIF
ENDDO
I = I + 1
FCHBUF(I, FD) = NEL
FCHCNT(FD) = I
ENDIF
ENDIF
STATUS = DERROR(FBLK(1, FD))
IF (STATUS .EQ. 3 .OR. STATUS .EQ. 4) FEOF(FD) = .TRUE.
ENDIF
RETURN
C
C end action
C
801 IOPEND(1) = IOCOMP; CALL X:XNWIO
802 IOPEND(2) = IOCOMP; CALL X:XNWIO
803 IOPEND(3) = IOCOMP; CALL X:XNWIO
804 IOPEND(4) = IOCOMP; CALL X:XNWIO
805 IOPEND(5) = IOCOMP; CALL X:XNWIO
806 IOPEND(6) = IOCOMP; CALL X:XNWIO
807 IOPEND(7) = IOCOMP; CALL X:XNWIO
808 IOPEND(8) = IOCOMP; CALL X:XNWIO
809 IOPEND(9) = IOCOMP; CALL X:XNWIO
810 IOPEND(10)= IOCOMP; CALL X:XNWIO
END
SUBROUTINE STTY(FD, FIELD, VALUE)
IMPLICIT NONE
INTEGER FD !port to set
CHARACTER*(*) FIELD !field to set
INTEGER VALUE !value to set to
C
C= Sets the specified field to the value
C
INCLUDE 'KVER.INS'
INCLUDE 'KFILE.COM'
LOGICAL*1 TTYECHO(MAXFILE) !local memory for echo
C
LOGICAL TUDT !test user device table
C
C
IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
CONTINUE
ELSE IF (FMODE(FD) .EQ. CLOSED) THEN
CONTINUE
C
C binary mode
C
ELSE IF (FIELD .EQ. 'BINARY') THEN
BINARY(FD) = VALUE .EQ. 1
CALL BLKINIT(FD)
C
C TIMEOUT
C
ELSE IF (FIELD .EQ. 'TIMEOUT') THEN
FTIMOUT(FD) = VALUE
C
C nowait
C
ELSE IF (FIELD .EQ. 'NOWAIT') THEN
NOWAIT(FD) = VALUE .EQ. 1
CALL BLKINIT(FD)
IF (FMODE(FD) .EQ. RD) THEN
C
C This section is used to enable timeouts since
C gould doesn't support a timeout on a normal read.
C You must be privileged to do this stuff
C
IF (LOCALON) THEN
IF (NOWAIT(FD)) THEN
C
CLT 2.3 CORRECTED TURNING ECHO ON AND OFF
C In this section (which incidentially must be called first) we
C memorize the previous condition of the udt so we can restore
C it to correct mode. This is part of rev. 2.3. This feature
C is particularly important for those using a network for file
C transmittal since they don't have echo on any way.
C
TTYECHO(FD) = TUDT(FBLK(1, FD), 'ECHO')
IF (TTYECHO(FD)) THEN
CALL SUDT(FBLK(1, FD), 'NOEC') !make sure
ENDIF
CALL SUDT(FBLK(1, FD), 'DUAL')
ELSE
CALL SUDT(FBLK(1, FD), 'SING')
IF (TTYECHO(FD)) THEN
CALL SUDT(FBLK(1, FD), 'ECHO') !may be right
ENDIF
ENDIF
ENDIF
ENDIF
C
C readsize
C
ELSE IF (FIELD .EQ. 'SIZE') THEN
IF (VALUE .GT. 0) THEN
FREQ(FD) = VALUE
ELSE
FREQ(FD) = MAXCH
ENDIF
IF (FREQ(FD) .GT. MAXCH) FREQ(FD) = MAXCH
CALL BLKINIT(FD)
C
C unrecognized field
C
ELSE
CONTINUE
ENDIF
RETURN
END
SUBROUTINE UNGETC(FD, CH)
IMPLICIT NONE
INTEGER FD !file descriptor
INTEGER CH !character put back
C
C= Try to put a character back into the input stream
C
C Ungetc can only put back characters as far as the beginning
C of the buffer. Hopefully, this is ok, since only getword
C does this with an nel which should be well into the buffer.
C
INCLUDE 'KFILE.COM'
C
IF (FCHPTR(FD) .GT. 1) THEN
FCHPTR(FD) = FCHPTR(FD) - 1
FCHBUF(FCHPTR(FD), FD) = CH
ENDIF
RETURN
END
INTEGER FUNCTION GETWORD(FD, STR, MAXLEN)
IMPLICIT NONE
INTEGER FD !file descriptor
INTEGER STR(*) !string to read to
INTEGER MAXLEN !max size of string
C
C= get a word from an input stream
C
C Getword considers a word to be delimited by blanks.
C It will return the length of the word as its value.
C
INCLUDE 'KFILE.COM'
C
INTEGER LEN !length of string
INTEGER CH !character
C
INTEGER GETC !get character
C
LEN = 0
C
C skip leading white space
C
10 CONTINUE
IF (GETC(FD, CH) .EQ. EOF) THEN
GETWORD = EOF
RETURN
ELSE IF (CH .EQ. NEL) THEN
GETWORD = 0
RETURN
ENDIF
IF (CH .EQ. BLANK .OR. CH .EQ. TAB) GOTO 10
C
C found first character, so keep going
C
DO WHILE (.NOT. (CH .EQ. EOF .OR. CH .EQ. BLANK .OR.
$ CH .EQ. TAB .OR. CH .EQ. NEL) .AND.
$ LEN .LT. MAXLEN)
LEN = LEN + 1
STR(LEN) = CH
CH = GETC(FD, CH)
ENDDO
C
C save eols for next getword
C
IF (CH .EQ. NEL) CALL UNGETC(FD, CH)
STR(LEN+1) = 0
GETWORD = LEN
RETURN
END
SUBROUTINE PUTSTR(FD, STR)
IMPLICIT NONE
INTEGER FD
INTEGER STR(*) !string to read
C
C= Output a string to an output stream
C
INCLUDE 'KFILE.COM'
C
INTEGER I
C
IF (FD .LT. 1 .OR. FD .GT. MAXFILE) THEN
ELSE IF (FMODE(FD) .EQ. WR) THEN
I = 1
DO WHILE (STR(I) .NE. 0)
CALL PUTC(FD, STR(I))
I = I + 1
ENDDO
ENDIF
RETURN
END
SUBROUTINE PUTINT (FD, INT, MINWID)
IMPLICIT NONE
INTEGER FD
INTEGER INT
INTEGER MINWID !minimum width
C
C= Output an integer
C
INCLUDE 'KDEF.INS'
C
INTEGER WIDTH
INTEGER VAL
INTEGER ASCIIO
INTEGER NCH !number of characters
INTEGER STRING(21)
C
INTEGER ICHAR
INTEGER IABS
INTEGER MOD
C
WIDTH = 0
IF (INT .LT. 0) THEN
CALL PUTC(FD, ICHAR('-'))
WIDTH = 1
ENDIF
VAL = IABS(INT)
ASCIIO = ICHAR('0')
NCH = 0
DO UNTIL (VAL .EQ. 0 .OR. NCH .GE. 20)
NCH = NCH + 1
STRING(NCH) = MOD(VAL, 10) + ASCIIO
VAL = VAL/10
ENDDO
WIDTH = WIDTH + NCH
C
C now output the digits
C
DO UNTIL (NCH .LE. 0)
CALL PUTC(FD, STRING(NCH))
NCH = NCH - 1
ENDDO
DO WHILE (WIDTH .LT. MINWID)
CALL PUTC(FD, BLANK)
WIDTH = WIDTH + 1
ENDDO
RETURN
END
SUBROUTINE PUTDAY(FD, MM, DD, YY)
IMPLICIT NONE
INTEGER FD
INTEGER MM, DD, YY
C
C= Output day of week
C
INTEGER IZLR
INTEGER IMN
INTEGER IYR
INTEGER IDY
INTEGER WKDAY
C
C day of week function!
C
IZLR (IYR, IMN, IDY) = MOD((13*(IMN+10-(IMN+10)/13*12)-1)/5+
$ IDY+77+5*(IYR+(IMN-14)/12-(IYR+(IMN-14)/12)/100*100)/4+
$ (IYR+(IMN-14)/12)/400-(IYR+(IMN-14)/12)/100*2,7)+1
C
WKDAY = IZLR(YY, MM, DD)
IF (WKDAY .EQ. 1) THEN
CALL PRINT(FD, 'Sunday')
ELSE IF (WKDAY .EQ. 2) THEN
CALL PRINT(FD, 'Monday')
ELSE IF (WKDAY .EQ. 3) THEN
CALL PRINT(FD, 'Tuesday')
ELSE IF (WKDAY .EQ. 4) THEN
CALL PRINT(FD, 'Wednesday')
ELSE IF (WKDAY .EQ. 5) THEN
CALL PRINT(FD, 'Thursday')
ELSE IF (WKDAY .EQ. 6) THEN
CALL PRINT(FD, 'Friday')
ELSE
CALL PRINT(FD, 'Saturday')
ENDIF
RETURN
END
SUBROUTINE PUTMNTH(FD, MM)
IMPLICIT NONE
INTEGER FD
INTEGER MM
C
C= Output the month name.
C
IF (MM .EQ. 1) THEN
CALL PRINT(FD, 'January')
ELSE IF (MM .EQ. 2) THEN
CALL PRINT(FD, 'Feburary')
ELSE IF (MM .EQ. 3) THEN
CALL PRINT(FD, 'March')
ELSE IF (MM .EQ. 4) THEN
CALL PRINT(FD, 'April')
ELSE IF (MM .EQ. 5) THEN
CALL PRINT(FD, 'May')
ELSE IF (MM .EQ. 6) THEN
CALL PRINT(FD, 'June')
ELSE IF (MM .EQ. 7) THEN
CALL PRINT(FD, 'July')
ELSE IF (MM .EQ. 8) THEN
CALL PRINT(FD, 'August')
ELSE IF (MM .EQ. 9) THEN
CALL PRINT(FD, 'September')
ELSE IF (MM .EQ. 10) THEN
CALL PRINT(FD, 'October')
ELSE IF (MM .EQ. 11) THEN
CALL PRINT(FD, 'November')
ELSE IF (MM .EQ. 12) THEN
CALL PRINT(FD, 'December')
ELSE
CALL PRINT(FD, 'No such month')
ENDIF
RETURN
END
SUBROUTINE PRINT (FD, STR)
IMPLICIT NONE
INTEGER FD
CHARACTER*(*) STR
C
C= Output character string
C
INTEGER I
C
INTEGER LEN
INTEGER ICHAR
C
DO I=1, LEN(STR)
CALL PUTC(FD, ICHAR(STR(I:I)))
ENDDO
RETURN
END
SUBROUTINE PRINTL(FD, STR)
IMPLICIT NONE
INTEGER FD
CHARACTER*(*) STR
C
C= Output a string with cr/lf at end
C
INCLUDE 'KDEF.INS'
C
CALL PUTC(FD, NEL)
CALL PRINT(FD, STR)
CALL FLUSH(FD)
RETURN
END
SUBROUTINE SENDBRK(FD)
IMPLICIT NONE
INTEGER FD !file to break
C
C Sends break to attached port
C
INCLUDE 'KFILE.COM'
C
INTEGER BLK(4) !local block
INTEGER BRK !function that turns on break
$ /X'62800000'/
INTEGER NOBRK !turn off break
$ /X'62000000'/ !break turned off
C
IF (FD .LE. 0 .AND. FD .GE. MAXFILE) THEN
ELSE IF (.NOT. CTDEV(FD)) THEN
ELSE IF (FMODE(FD) .NE. WR) THEN
ELSE
CALL FLUSH(FD)
CALL FCBINIT(FD, BLK, BRK, 0)
CALL DPWRITE(BLK, 0, 0)
CALL DELAY(60)
CALL FCBINIT(FD, BLK, NOBRK, 0)
CALL DPWRITE(BLK, 0, 0)
CALL BLKINIT(FD)
ENDIF
RETURN
END
SUBROUTINE IOWAIT (MSEC)
IMPLICIT NONE
INTEGER MSEC !msec to wait for io to complete
C
C= Delays the specified time if io is pending
C
INTEGER IOS
C
INTEGER MIN
C
C
CALL X:EAWAIT(MIN(-1,-MSEC/50), IOS, *10)
10 CONTINUE
RETURN
END