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. 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 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