* BASE -ULTLY-KERM -SFM-A2703 - 08/01/90 WJH HEADER SFMKERM 0001.000 PROGRAM KERMIT 0001.100 IMPLICIT NONE 0002.000 C 0003.000 C= File transfer program using kermit protocol 0004.000 C 0005.000 C 0006.000 C REVISION LIST 0007.000 C 0008.000 C 1.0 This Kermit was the direct implemention of the Cyber-170 0009.000 C version, University of Texas. L. Tate, SAI, Sept. 1985. 0010.000 C 0011.000 C 2.0 Added the CONNECT, GET, FINISH, BYE commands. This required 0012.000 C significant changes to the io interface. The local on/off 0013.000 C option was also part of this. L. Tate, SAI, Nov. 1985. 0014.000 C 0015.000 C 2.1 Correct bug in SUDT. When use the SVC 1,X'27' which 0016.000 C set full duplex on a terminal it previously used a trashed 0017.000 C file control block. This had caused unpredicatable results 0018.000 C in alot of the io including 2 reads pending at once. 0019.000 C Correcting this problem allowed removal of HIOALL routine. 0020.000 C Files to be read are opened with OPENMODE='R' and files to 0021.000 C be written are opened with OPENMODE='U'. Also added the 0022.000 C TAKE command. L. Tate, SAI, Mar. 1986. 0023.000 C 0024.000 C 2.2 Improved receive/get reliablity by moving the terminal 0025.000 C reporting to before the ACK/NAK is sent. The problem seems 0026.000 C to have been during the reporting time, the sending flooded 0027.000 C the 8-line buffer and caused a break, losing data. Also 0028.000 C corrected error in printl routine which wrote to stdout 0029.000 C instead of the parameter fd. L. Tate, SAI, Mar. 1986. 0030.000 C 0031.000 C 2.3 Added to SERVER the ability to recognize the I packet. 0032.000 C This packet is used by advanced Kermits (2.27 at least) 0033.000 C to initialize the Server. 0034.000 C Changed the method by which nowait is established so that 0035.000 C if ECHO was off for the terminal before kermit operation, 0036.000 C it will remain so afterwards. Good for network operation. 0037.000 C Corrected the error reporting code such that now the error 0038.000 C messages are produced. However, they can be very cryptic. 0039.000 C What is needed is a general method of handling text, like 0040.000 C help messages and error messages, such that memory is not 0041.000 C filled but ready access is available. 0042.000 C L. TATE, SAI, MAY 1986. 0043.000 C 0044.000 C AS IN TO LFC=UT 0045.000 C AS OUT TO LFC=UT 0046.000 C 0047.000 C 0048.000 C 2.4 Modified to run on GOULD 32/77 machine using the MPX 1.5E 0049.000 C operating system. 0050.000 C B.WILSON, QEC, JANUARY 1989 0051.000 C 0052.000 C 0053.000 C 0054.000 INCLUDE K.KERMV 0055.000 INCLUDE K.KERMD 0056.000 INCLUDE K.PROTC 0057.000 INCLUDE K.MSGCOM 0058.000 INCLUDE K.DBUGC 0059.000 C 0060.000 INTEGER NCMD ;PARAMETER (NCMD=15) 0061.000 CHARACTER*10 CMD(NCMD) !commands 0062.000 $ /'BYE', 'CONNECT','EXIT','FINISH','GET','HELP', 0063.000 $ 'QUIT','RECEIVE','SEND','SERVER', 0064.000 $ 'SET', 'SHOW', 'STATUS','TAKE', 'X'/ 0065.000 INTEGER NNOLOCAL ;PARAMETER (NNOLOCAL = 3) 0066.000 CHARACTER*63 NOLOCAL (NNOLOCAL) 0067.000 $/'This KERMIT does not support the following commands; BYE,', 0068.000 $ 'CONNECT, FINISH, SEND and GET. These commands require KERMIT', 0069.000 $ 'to be installed on MPX3.2B or greater.'/ 0070.000 INTEGER IDX !current command 0071.000 CHARACTER*80 CMDLIN !command line that started program 0072.000 INTEGER IOS 0073.000 C 0074.000 INTEGER MATCH !get and match command 0075.000 INTEGER OPEN 0076.000 C 0077.000 INPUTFD = 0 0077.100 CALL SLINE(CMDLIN) !get startup command line 0078.000 CALL INIT(CMDLIN) !pass to initialize 0079.000 C 0080.000 IOS = OPEN('STDIN','R') 0081.000 IF (IOS .NE. STDIN) THEN 0082.000 CALL PRTMSG(' Cannot open standard input', -IOS) 0083.000 STOP 0084.000 ENDIF 0085.000 IOS = OPEN('STDOUT','W') 0086.000 IF (IOS .NE. STDOUT) THEN 0087.000 CALL PRTMSG(' Cannot open standard output',-IOS) 0088.000 STOP 0089.000 ENDIF 0090.000 C 0091.000 C initializing program 0092.000 C 0093.000 C INPUTFD = OPEN('KERM.INI', 'R') 0094.000 IF (INPUTFD .LE. 0) INPUTFD = STDIN 0095.000 C 0096.000 CALL PRINTL(STDOUT, VERSION) 0097.000 DO BEGIN 0098.000 IF (INPUTFD .EQ. STDIN) THEN 0099.000 CALL PUTSTR(STDOUT, PROMPT) 0100.000 CALL FLUSH(STDOUT) 0101.000 ENDIF 0102.000 CALL FLUSH(INPUTFD) 0103.000 IDX = MATCH(CMD, NCMD, .TRUE.) 0104.000 IF (IDX .EQ. ERROR .OR. IDX .EQ. 0) GOTO 200 0105.000 IF (IDX .EQ. EOF) THEN 0106.000 IF (INPUTFD .NE. STDIN) THEN 0107.000 CALL TAKEDONE 0108.000 GOTO 200 0109.000 ELSE 0110.000 CALL EXITPGM 0111.000 ENDIF 0112.000 ENDIF 0113.000 GOTO (130, 40, 50, 140, 20, 90, 50, 30, 10, 80, 100, 0114.000 $ 110, 120, 60, 50 ) IDX 0115.000 C 0116.000 10 CONTINUE !send - Not debugged yet 0117.000 C CALL SNDFILE 0118.000 C GOTO 200 0119.000 GO TO 190 0120.000 20 CONTINUE !get 0121.000 IF (.NOT. LOCALON) GOTO 190 0122.000 CALL GETFROM 0123.000 GOTO 200 0124.000 30 CONTINUE !receive 0125.000 CALL RCVFILE 0126.000 GOTO 200 0127.000 40 CONTINUE !connect 0128.000 IF (.NOT. LOCALON) GOTO 190 0129.000 CALL CONNECT 0130.000 GOTO 200 0131.000 50 CONTINUE !exit 0132.000 CALL EXITPGM 0133.000 60 CONTINUE !take 0134.000 CALL TAKE 0135.000 GOTO 200 0136.000 80 CONTINUE !server 0137.000 CALL SERVER 0138.000 CALL INIT(CMDLIN) 0138.100 GOTO 200 0139.000 90 CONTINUE !help 0140.000 CALL HELP 0141.000 GOTO 200 0142.000 100 CONTINUE !set 0143.000 CALL SET 0144.000 GOTO 200 0145.000 110 CONTINUE !show 0146.000 CALL SHOW 0147.000 GOTO 200 0148.000 120 CONTINUE !status 0149.000 CALL STATUS 0150.000 GOTO 200 0151.000 130 CONTINUE !bye 0152.000 IF (.NOT. LOCALON) GOTO 190 0153.000 CALL BYE 0154.000 GOTO 200 0155.000 140 CONTINUE !finish 0156.000 IF (.NOT. LOCALON) GOTO 190 0157.000 CALL FINISH 0158.000 GOTO 200 0159.000 190 CONTINUE !no local 0160.000 CALL OUTTBL(NOLOCAL, 1, NNOLOCAL) 0161.000 GOTO 200 0162.000 210 CONTINUE 0162.100 200 CONTINUE 0163.000 ENDDO 0164.000 END 0165.000 SUBROUTINE INIT(COMLIN) 0166.000 IMPLICIT NONE 0167.000 CHARACTER*80 COMLIN !command line of program 0168.000 C 0169.000 C= initializes all kermit context 0170.000 C 0171.000 INCLUDE K.KERMV 0172.000 INCLUDE K.KERMD 0173.000 INCLUDE K.DBUGC 0174.000 INCLUDE K.PROTC 0175.000 INCLUDE K.PACKC 0176.000 INCLUDE K.MSGCOM 0177.000 C 0178.000 INTEGER I !index 0179.000 CHARACTER*2 MACH !machine type code 0180.000 C 0181.000 INTEGER LASTCHR !last non blank character 0182.000 INTRINSIC ICHAR !character to int 0183.000 C INTEGER ICHAR 0183.100 INTEGER MATCH 0184.000 INTEGER OPEN 0185.000 C 0186.000 C dbugcom 0187.000 C 0188.000 C CALL M_UPRIV 0189.000 CALL BREAKR 0190.000 C 0191.000 DEBUG = .FALSE. !no debug on 0192.000 DBGFD = 0 !standoutput 0193.000 DBGFILE = 'KERMLOG' !standoutput 0194.000 C 0195.000 C protcom 0196.000 C 0197.000 PACKET = 0 0198.000 RECPACK = 0 0199.000 FILESTR = 0 0200.000 PSIZE = 0 0201.000 PACKNUM = 0 0202.000 NUMTRY = 0 0203.000 MAXRTRY = MAXTRY 0204.000 MAXRINI = MAXINIT 0205.000 STATE = C 0206.000 IFD = STDIN 0207.000 OFD = STDOUT 0208.000 COMPORT = 'UT' 0209.000 FFD = 0 0210.000 DELAYFP = 0 0211.000 STARTIM = 0 0212.000 ENDTIM = 0 0213.000 SCHCNT = 0 0214.000 RCHCNT = 0 0215.000 SCHOVRH = 0 0216.000 RCHOVRH = 0 0217.000 ECHO = .FALSE. 0218.000 ESCCHR = 29 ! CONTROL-] 0219.000 LOG = .FALSE. 0220.000 LFD = 0 0221.000 LOGFILE = 'KERMSESN' 0222.000 INSTACK = 0 !initialize stack pointer 0223.000 INSTKFD = 0 !zero stack for good measure 0224.000 C 0225.000 C packcom 0226.000 C 0227.000 SYNC = SNDSYNC = SOH 0228.000 PACKSIZ = SPKSIZ = MAXPACK 0229.000 TIMEOUT = STIMOUT = MYTIME 0230.000 NPAD = SPAD = MYPAD 0231.000 PADCH = SPADCH = MYPADCH 0232.000 EOLCH = SPEOL = MYEOL 0233.000 QUOTECH = SPQUOTE = MYQUOTE 0234.000 QUOTE8 = S8QUOTE = QUOT8CH 0235.000 CHKTYP = SCHKTYP = MYCKTYP 0236.000 RESERVE = UNUSED = 0 0237.000 RPREFIX = SREPEAT = PREFXCH 0238.000 C 0239.000 C msgcom 0240.000 C 0241.000 IF (LOCALON) THEN 0242.000 VERSION = 'Gould KERMIT version 2.3, Local/Remote enabled' 0243.000 ELSE 0244.000 VERSION = 'Gould KERMIT version 2.3, Local/Remote disabled' 0245.000 ENDIF 0246.000 CALL GETMACH(MACH) 0247.000 PROMPT(1) = NEL 0248.000 CALL DPC2AS('kermit-'//MACH//'>', PROMPT(2), 19) 0249.000 I = LASTCHR(COMLIN) 0250.000 IF (I .GT. 18 ) I = 18 0251.000 IF (I .GT. 0) CALL DPC2AS(COMLIN(:I)//'>', PROMPT(2), I+1) 0252.000 CLT 2.3 FIXED THE LOGIC FOR LNAME 0253.000 I = 2 0254.000 LNAME = 0 0255.000 DO WHILE (PROMPT(I) .NE. ICHAR('>') .AND. I .LT. 21) 0256.000 LNAME = LNAME + 1 0257.000 NAME(LNAME) = PROMPT(I) 0258.000 I = I + 1 0259.000 ENDDO 0260.000 C 0261.000 CALL BREAKR 0262.000 CALL X:SYNCH 0263.000 C 0264.000 RETURN 0265.000 END 0266.000 SUBROUTINE EXITPGM 0267.000 IMPLICIT NONE 0268.000 C 0269.000 C= Exit kermit 0270.000 C 0271.000 INTEGER I !index 0272.000 C 0273.000 DO I=1, 10 0274.000 CALL CLOSE(I) 0275.000 ENDDO 0276.000 CALL EXIT 0277.000 END 0278.000 SUBROUTINE RCVFILE 0279.000 IMPLICIT NONE 0280.000 C 0281.000 C= Top level subroutine to start receive state. 0282.000 C 0283.000 INCLUDE K.KERMD 0284.000 INCLUDE K.PROTC 0285.000 INCLUDE K.PACKC 0286.000 C 0287.000 INTEGER RECEIVE !receive file 0288.000 INTEGER GTTY !get tty status 0289.000 LOGICAL CONFIRM !confirm input 0290.000 C 0291.000 IF (.NOT. CONFIRM(INPUTFD)) RETURN 0292.000 C 0293.000 C receive file 0294.000 C 0295.000 CALL STTY(IFD, 'BINARY', ON) 0296.000 CALL STTY(IFD, 'TIMEOUT', TIMEOUT) 0297.000 CALL STTY(IFD, 'NOWAIT', ON) 0298.000 IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN 0299.000 CALL PRINTL(STDOUT, 'Receiving file ') 0300.000 CALL PUTSTR(STDOUT, FILESTR) 0301.000 CALL FLUSH(STDOUT) 0302.000 ENDIF 0303.000 IF (RECEIVE(R) .EQ. OK) THEN 0304.000 CALL PRINTL(STDOUT, 'Receive complete.') 0305.000 ELSE 0306.000 CALL PRINTL(STDOUT, 'Received failed.') 0307.000 ENDIF 0308.000 CALL STTY(IFD, 'NOWAIT', OFF) 0309.000 CALL STTY(IFD, 'TIMEOUT', 0) 0310.000 CALL STTY(IFD, 'BINARY', OFF) 0311.000 RETURN 0312.000 END 0313.000 SUBROUTINE SNDFILE 0314.000 IMPLICIT NONE 0315.000 C 0316.000 C= Sends a file to other kermit 0317.000 C 0318.000 INCLUDE K.KERMD 0319.000 INCLUDE K.PROTC 0320.000 INCLUDE K.PACKC 0321.000 C 0322.000 CHARACTER*8 FNAME !name of file to send 0323.000 INTEGER IRET !return status 0324.000 C 0325.000 LOGICAL ISFILE 0326.000 INTEGER SEND 0327.000 C 0328.000 C pick up file name and save it for opening later 0329.000 C 0330.000 CALL SETVAL(FILESTR, 'S', IRET, 16, 0, 0, 0331.000 $ 'Filename to send', .TRUE.) 0332.000 IF (IRET .EQ. ERROR) RETURN 0333.000 C 0334.000 C check to make sure it's there to send 0335.000 C 0336.000 CALL AS2DPC(FILESTR, FNAME) 0337.000 IF (.NOT. ISFILE(FNAME)) THEN 0338.000 CALL PRINTL(STDOUT, '?File ') 0339.000 CALL PUTSTR(STDOUT, FILESTR) 0340.000 CALL PRINT(STDOUT,' is not found.') 0341.000 CALL PUTC(STDOUT, NEL) 0342.000 RETURN 0343.000 ENDIF 0344.000 C 0345.000 CALL STTY(IFD, 'BINARY', ON) 0346.000 CALL STTY(IFD, 'TIMEOUT', TIMEOUT) 0347.000 CALL STTY(IFD, 'NOWAIT', ON) 0348.000 C 0349.000 C delay the first packet 0350.000 C 0351.000 IF (DELAYFP .GT. 0) CALL SLEEP(DELAYFP) 0352.000 C 0353.000 C start sending packet 0354.000 C 0355.000 IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN 0356.000 CALL PRINTL(STDOUT, 'Sending file ') 0357.000 CALL PUTSTR(STDOUT, FILESTR) 0358.000 CALL FLUSH(STDOUT) 0359.000 ENDIF 0360.000 PACKNUM = 0 0361.000 IF (SEND() .EQ. OK) THEN 0362.000 CALL PRINTL(STDOUT, 'Send complete.') 0363.000 ELSE 0364.000 CALL PRINTL(STDOUT, 'Send failed.') 0365.000 ENDIF 0366.000 CALL STTY(IFD, 'NOWAIT', OFF) 0367.000 CALL STTY(IFD, 'TIMEOUT', 0) 0368.000 CALL STTY(IFD, 'BINARY', OFF) 0369.000 RETURN 0370.000 END 0371.000 SUBROUTINE SERVER 0372.000 IMPLICIT NONE 0373.000 C 0374.000 C= Start kermit server routine 0375.000 C 0376.000 C The server currently knows about the send and receive packets 0377.000 C and also the generic kermit packets logout and finish. 0378.000 C 0379.000 INCLUDE K.KERMD 0380.000 INCLUDE K.DBUGC 0381.000 INCLUDE K.PROTC 0382.000 INCLUDE K.PACKC 0383.000 C 0384.000 INTEGER PTYP 0385.000 INTEGER I 0386.000 INTEGER NUM !packet number 0387.000 INTEGER RECSTAT !receive status 0388.000 INTEGER SNDSTAT !send status 0389.000 CHARACTER*72 SRVMES (4 ) 0390.000 $ /'[Kermit SERVER running on Gould host. Please type your', 0391.000 $ 'escape sequence ( altK ) to return to your local machine', 0392.000 $ 'Use GET to request a file from the GOULD host. ', 0393.000 $ 'Use FINISH to return control to GOULD host.]'/ 0394.000 CHARACTER*56 FILENAME 0395.000 INTEGER*8 FINAME 0396.000 CHARACTER*8 FCNAME 0397.000 EQUIVALENCE (FILENAME,FINAME,FCNAME) 0398.000 C 0399.000 LOGICAL CONFIRM 0400.000 INTEGER RDPACK !read a packet 0401.000 INTEGER SNDPAR !build init packet 0402.000 INTEGER GTTY !get terminal stuff 0403.000 INTEGER RECEIVE !receive file 0404.000 INTEGER SEND !send file 0405.000 INTEGER LASTCHR !last non-blank character 0406.000 INTEGER MAX 0407.000 INTEGER SLEN !string length 0408.000 INTEGER USCMD 0408.100 LOGICAL ISFILE !does file exist 0409.000 INTEGER M /'A'/ 0409.010 C 0409.100 INTRINSIC MOD 0409.200 C 0410.000 IF (.NOT. CONFIRM(INPUTFD)) RETURN 0411.000 C 0412.000 C initialize msg #, say no tries yet 0413.000 C 0414.000 PACKNUM = 0 0415.000 USCMD = 0 0415.100 NUMTRY = 0 0416.000 CALL OUTTBL(SRVMES, 1, 4) 0417.000 C 0418.000 CALL STTY(IFD, 'BINARY', ON) 0419.000 CALL STTY(IFD, 'TIMEOUT', TIMEOUT) 0420.000 CALL STTY(IFD, 'NOWAIT', ON) 0421.000 CALL STTY(IFD, 'SIZE' ,768) 0421.100 C 0422.000 10 CONTINUE 0423.000 PTYP = RDPACK(LEN, NUM, RECPACK) 0424.000 X WRITE(19,1000)PTYP,LEN,NUM 0424.100 X1000 FORMAT(' 4242** ',8(1X,1Z8)) 0424.200 IF (PTYP .EQ. S) THEN 0425.000 PACKNUM = NUM 0426.000 CALL RDPARAM(RECPACK) 0427.000 I = SNDPAR(PACKET) 0428.000 X WRITE(19,1001)Y,PACKNUM,I,PACKET 0428.100 X1001 FORMAT(' 428.2** ',8(1X,1Z8)) 0428.200 CALL SNDPACK(Y, PACKNUM, I, PACKET) 0429.000 NUMTRY = 0 0430.000 PACKNUM = MOD(PACKNUM+1, 64) 0431.000 RECSTAT = RECEIVE(F) 0432.000 X WRITE(19,1002)RECSTAT 0432.100 X1002 FORMAT(' 432.2** ',1Z8) 0432.200 IF (DEBUG(DBGON)) THEN 0433.000 IF (RECSTAT .EQ. ERROR) THEN 0434.000 CALL PRINTL(DBGFD, 'Receive failed.') 0435.000 ELSE 0436.000 CALL PRINTL(DBGFD, 'Receive completed.') 0437.000 ENDIF 0438.000 ENDIF 0439.000 ELSE IF (PTYP .EQ. M) THEN 0439.100 CALL SNDPACK(Y, NUM, 0, 0) 0439.200 CALL STTY(IFD, 'NOWAIT', OFF) 0439.300 CALL STTY(IFD, 'TIMEOUT', 0) 0439.400 CALL STTY(IFD, 'BINARY', OFF) 0439.500 ELSE IF (PTYP .EQ. R) THEN 0440.000 C IF (DEBUG(DBGON)) THEN 0441.000 C CALL PRINTL(DBGFD, 'SERVER: PACKET TYPE IS R ') 0442.000 C ENDIF 0443.000 I = 0 0444.000 CALL STRCPY(RECPACK, FILESTR) 0445.000 CALL AS2DPC(FILESTR, FILENAME) 0446.000 CALL FILCHK(FCNAME) 0447.000 X WRITE(19,890)FILENAME 0447.100 X890 FORMAT(' 890** ',1X,1A56) 0447.200 C 0448.000 CLT 2.3 5/12/86 CHECK TO SEE IF FILE EXISTS 0449.000 C 0450.000 IF (ISFILE(FINAME)) THEN 0451.000 IF (DEBUG(DBGON)) THEN 0452.000 CALL PRINTL(DBGFD, 'SERVER: FILE FOUND ') 0453.000 ENDIF 0454.000 CALL DPC2AS(FILENAME, FILESTR, MAX(1,LASTCHR(FILENAME))) 0455.000 X WRITE(19,900) 0455.100 X900 FORMAT(' SERVER : FILE FOUND ') 0455.200 SNDSTAT = SEND() 0456.000 PACKNUM = 0 0457.000 IF (DEBUG(DBGON)) THEN 0458.000 IF (SNDSTAT .EQ. ERROR) THEN 0459.000 CALL PRINTL(DBGFD, 'Send failed.') 0460.000 ELSE 0461.000 CALL PRINTL(DBGFD, 'Send completed.') 0462.000 ENDIF 0463.000 ENDIF 0464.000 CLT 2.3 5/12/86 SEND ERROR PACKET IF NOT FOUND 0465.000 ELSE 0466.000 CALL DPC2AS('? FILE ', PACKET, 7) 0467.000 I = LASTCHR(FILENAME) 0468.000 CALL DPC2AS(FILENAME, PACKET(8), I) 0469.000 CALL DPC2AS(' NOT FOUND', PACKET(I+8), 10) 0470.000 CALL SNDPACK(E, PACKNUM, SLEN(PACKET), PACKET) 0471.000 ENDIF 0472.000 ELSE IF (PTYP .EQ. G) THEN 0473.000 IF (RECPACK(1) .EQ. L) THEN 0474.000 CALL SNDPACK(Y, NUM, 0, 0) 0475.000 CALL STTY(IFD, 'NOWAIT', OFF) 0476.000 CALL STTY(IFD, 'TIMEOUT', 0) 0477.000 CALL STTY(IFD, 'BINARY', OFF) 0478.000 CCCCCCC CALL EXITPGM !LOGOUT WH JAN 90 0479.000 RETURN 0479.100 ELSE IF (RECPACK(1) .EQ. F) THEN 0480.000 CALL SNDPACK(Y, NUM, 0, 0) 0481.000 CALL STTY(IFD, 'NOWAIT', OFF) 0482.000 CALL STTY(IFD, 'TIMEOUT', 0) 0483.000 CALL STTY(IFD, 'BINARY', OFF) 0484.000 CCCCCCC CALL EXITPGM ! WH JAN 90 0485.000 RETURN 0485.100 C 0486.000 CLT 2.3 5/12/86 SEND ERROR MESSAGE FOR UNSUPPORTED COMMAND 0487.000 C 0488.000 ELSE 0489.000 CALL DPC2AS('? UNSUPPORTED SERVER COMMAND', PACKET, 28) 0490.000 CALL SNDPACK(E, PACKNUM, SLEN(PACKET), PACKET) 0491.000 ENDIF 0492.000 C 0493.000 CLT 2.3 5/8/86 RECEIVE SERVER INIT PACKET 0494.000 C 0495.000 ELSE IF (PTYP .EQ. ITYP) THEN 0496.000 PACKNUM = NUM 0497.000 CALL RDPARAM(RECPACK) 0498.000 I = SNDPAR(PACKET) 0499.000 CALL SNDPACK(Y, PACKNUM, I, PACKET) 0500.000 C 0501.000 CLT END 0502.000 C 0503.000 ELSE 0504.000 CLT 2.3 5/12/86 Added error message for unrecognized packet 0505.000 CALL DPC2AS('? UNRECOGNIZED SERVER PACKET',PACKET,28) 0506.000 CALL SNDPACK(E,PACKNUM, SLEN(PACKET), PACKET) 0507.000 IF (DEBUG(DBGON)) THEN 0508.000 CALL PRINTL(DBGFD, 'server: invalid packet type: ') 0509.000 CALL PUTINT(DBGFD, PTYP, 1) 0510.000 CALL FLUSH(DBGFD) 0511.000 ENDIF 0512.000 CALL SNDPACK(Y, NUM, 0, 0) 0512.100 CALL STTY(IFD, 'NOWAIT', OFF) 0512.200 CALL STTY(IFD, 'TIMEOUT', 0) 0512.300 CALL STTY(IFD, 'BINARY', OFF) 0512.400 CCCCCCC CALL EXITPGM ! WH JAN 90 0512.500 USCMD = USCMD + 1 0512.510 IF (USCMD.LT.3)GO TO 10 0512.520 RETURN 0512.600 C 0512.700 ENDIF 0513.000 GOTO 10 0514.000 END 0515.000 SUBROUTINE SET 0516.000 IMPLICIT NONE 0517.000 C 0518.000 C= Set some attributes. 0519.000 C 0520.000 INCLUDE K.KERMV 0521.000 INCLUDE K.KERMD 0522.000 INCLUDE K.PROTC 0523.000 INCLUDE K.PACKC 0524.000 C 0525.000 INTEGER TSIZE !set commands 0526.000 PARAMETER (TSIZE = 10) 0527.000 CHARACTER*10 SETTYP(TSIZE) 0528.000 $ /'DEBUG','DELAY','ECHO', 'ESCAPE', 0529.000 $ 'INIT-RETRY','LOG','PORT','RECEIVE','RETRY','SEND'/ 0530.000 INTEGER NNOLOCAL ;PARAMETER (NNOLOCAL = 3 ) 0531.000 CHARACTER*63 NOLOCAL (NNOLOCAL) 0532.000 $/'This KERMIT does not support the following SET commands;', 0533.000 $ 'PORT and LOG. These commands require KERMIT to be installed', 0534.000 $ 'on MPX3.2B or greater.'/ 0535.000 INTEGER INDX 0536.000 INTEGER ESIZE ;PARAMETER (ESIZE = 2) 0537.000 CHARACTER*3 ECHOTYP(ESIZE) /'OFF','ON'/ 0538.000 CHARACTER*63 HLPASCH/ 0539.000 $'Decimal, octal (O), or hexidecimal (H) code for ASCII character' 0540.000 $/ 0541.000 C 0542.000 INTEGER MATCH 0543.000 C 0544.000 INDX = MATCH (SETTYP, TSIZE, .FALSE.) 0545.000 IF (INDX .LE. 0) RETURN 0546.000 GOTO (10, 20, 23, 27, 30, 80, 70, 40, 50, 60) INDX 0547.000 C 0548.000 C set debugging modes 0549.000 C 0550.000 10 CONTINUE !debug 0551.000 CALL DBUGCMD 0552.000 RETURN 0553.000 C 0554.000 20 CONTINUE !set first packet delay 0555.000 CALL SETVAL(DELAYFP,'I',0,60,0,60, 0556.000 $ 'Number of seconds to delay first packet', .TRUE.) 0557.000 RETURN 0558.000 C 0559.000 23 CONTINUE !set echo on/off 0560.000 INDX = MATCH(ECHOTYP, ESIZE, .TRUE.) 0561.000 IF (INDX .LE. 0) RETURN 0562.000 ECHO = INDX .EQ. 2 0563.000 RETURN 0564.000 C 0565.000 27 CONTINUE !escape 0566.000 CALL SETVAL(ESCCHR, 'I', 0, 31, 0, 31, HLPASCH, .TRUE.) 0567.000 RETURN 0568.000 C 0569.000 30 CONTINUE ! set initial packet retry count 0570.000 CALL SETVAL(MAXRINI,'I',1,50,1,50, 0571.000 $ 'Initial packet retry count', .TRUE.) 0572.000 RETURN 0573.000 C 0574.000 40 CONTINUE !set receive packet attributes 0575.000 CALL SETPACK(PACKSIZ) 0576.000 RETURN 0577.000 C 0578.000 50 CONTINUE !set packet retry count 0579.000 CALL SETVAL(MAXRTRY, 'I',1,50,1,50, 0580.000 $ 'Packet retry count', .TRUE.) 0581.000 RETURN 0582.000 C 0583.000 60 CONTINUE !set send packet attributes 0584.000 CALL SETPACK(SPKSIZ) 0585.000 RETURN 0586.000 C 0587.000 70 CONTINUE !set port 0588.000 IF (.NOT. LOCALON) GOTO 90 0589.000 CALL PORTCMD 0590.000 RETURN 0591.000 C 0592.000 80 CONTINUE !set log 0593.000 IF (.NOT. LOCALON) GOTO 90 0594.000 CALL LOGGER 0595.000 RETURN 0596.000 C 0597.000 90 CONTINUE !no local 0598.000 CALL OUTTBL(NOLOCAL, 1, NNOLOCAL) 0599.000 RETURN 0600.000 END 0601.000 SUBROUTINE SHOW 0602.000 IMPLICIT NONE 0603.000 C 0604.000 C= Show the current program settings 0605.000 C 0606.000 INCLUDE K.KERMV 0607.000 INCLUDE K.KERMD 0608.000 INCLUDE K.PROTC 0609.000 INCLUDE K.PACKC 0610.000 INCLUDE K.DBUGC 0611.000 INCLUDE K.MSGCOM 0612.000 C 0613.000 INTEGER MM,DD,YY,HR,MIN,SEC 0614.000 C 0615.000 INTEGER CTL 0616.000 LOGICAL CONFIRM 0617.000 C 0618.000 IF (.NOT. CONFIRM(INPUTFD)) RETURN 0619.000 CALL PRINTL(STDOUT, VERSION) 0620.000 C 0621.000 C display current date and time 0622.000 C 0623.000 CALL GETNOW(MM, DD, YY, HR, MIN, SEC) 0624.000 CALL PUTC(STDOUT, NEL) 0625.000 CALL PUTDAY(STDOUT, MM, DD, YY) 0626.000 CALL PRINT(STDOUT,', ') 0627.000 CALL PUTMNTH(STDOUT,MM) 0628.000 CALL PUTC(STDOUT,ICHAR(' ')) 0629.000 CALL PUTINT(STDOUT,DD, 1) 0630.000 CALL PRINT(STDOUT,', ') 0631.000 CALL PUTINT(STDOUT,YY, 1) 0632.000 CALL PUTC(STDOUT,ICHAR(' ')) 0633.000 IF (HR .LT. 10) CALL PRINT(STDOUT,'0') 0634.000 CALL PUTINT(STDOUT,HR,1) 0635.000 CALL PUTC(STDOUT,ICHAR(':')) 0636.000 IF (MIN .LT. 10) CALL PRINT(STDOUT,'0') 0637.000 CALL PUTINT(STDOUT,MIN,1) 0638.000 CALL PUTC(STDOUT,ICHAR(':')) 0639.000 IF (SEC .LT. 10) CALL PRINT(STDOUT,'0') 0640.000 CALL PUTINT(STDOUT,SEC,1) 0641.000 C 0642.000 C display current debug modes 0643.000 C 0644.000 CALL PRINTL(STDOUT,'Debugging: ') 0645.000 IF (DEBUG(DBGSTAT)) CALL PRINT(STDOUT,'States ') 0646.000 IF (DEBUG(DBGPACK)) CALL PRINT(STDOUT,'Packets ') 0647.000 IF (.NOT. DEBUG(DBGON)) CALL PRINT(STDOUT,'Off ') 0648.000 IF (DEBUG(DBGON)) THEN 0649.000 CALL PRINT(STDOUT,' Debug log file: '//DBGFILE) 0650.000 ENDIF 0651.000 C 0652.000 C session log 0653.000 C 0654.000 IF (LOCALON) THEN 0655.000 CALL PRINTL(STDOUT, 'Session log: ') 0656.000 IF (LOG) THEN 0657.000 CALL PRINT(STDOUT, 'ON') 0658.000 ELSE 0659.000 CALL PRINT(STDOUT, 'OFF') 0660.000 ENDIF 0661.000 IF (LOGFILE .NE. ' ') THEN 0662.000 CALL PRINT( STDOUT, ' Session log file: ') 0663.000 CALL PRINT(STDOUT, LOGFILE) 0664.000 ENDIF 0665.000 ENDIF 0666.000 C 0667.000 C display current port 0668.000 C 0669.000 IF (LOCALON) THEN 0670.000 CALL PRINTL(STDOUT, 'Selected Communications port: ') 0671.000 CALL PRINT (STDOUT, COMPORT) 0672.000 CALL PRINTL(STDOUT, 'Connection escape character: ^') 0673.000 CALL PUTC(STDOUT, CTL(ESCCHR)) 0674.000 CALL PRINTL(STDOUT, 'Local echo: ') 0675.000 IF (ECHO) THEN 0676.000 CALL PRINT(STDOUT, 'ON') 0677.000 ELSE 0678.000 CALL PRINT(STDOUT, 'OFF') 0679.000 ENDIF 0680.000 ENDIF 0681.000 C 0682.000 C display packet settings 0683.000 C 0684.000 CALL PRINTL(STDOUT,'Packet Parameters') 0685.000 CALL PRINTL(STDOUT, 0686.000 $ ' Receive Send') 0687.000 CALL PRINTL(STDOUT,' Size: ') 0688.000 CALL PUTINT(STDOUT,PACKSIZ,10) 0689.000 CALL PUTINT(STDOUT,SPKSIZ,10) 0690.000 CALL PRINTL(STDOUT,' Timeout: ') 0691.000 CALL PUTINT(STDOUT,TIMEOUT,10) 0692.000 CALL PUTINT(STDOUT,STIMOUT,10) 0693.000 CALL PRINTL(STDOUT,' Padding: ') 0694.000 CALL PUTINT(STDOUT,NPAD,10) 0695.000 CALL PUTINT(STDOUT,SPAD,10) 0696.000 CALL PRINTL(STDOUT,' Pad character: ') 0697.000 CALL PUTC(STDOUT,ICHAR('^')) 0698.000 CALL PUTC(STDOUT,CTL(PADCH)) 0699.000 CALL PRINT(STDOUT,' ') 0700.000 CALL PUTC(STDOUT,ICHAR('^')) 0701.000 CALL PUTC(STDOUT,CTL(SPADCH)) 0702.000 CALL PRINTL(STDOUT,' End-of-Line: ') 0703.000 CALL PUTC(STDOUT,ICHAR('^')) 0704.000 CALL PUTC(STDOUT,CTL(EOLCH)) 0705.000 CALL PRINT(STDOUT,' ') 0706.000 CALL PUTC(STDOUT,ICHAR('^')) 0707.000 CALL PUTC(STDOUT,CTL(SPEOL)) 0708.000 CALL PRINTL(STDOUT,' Control quote: ') 0709.000 CALL PUTC(STDOUT,QUOTECH) 0710.000 CALL PRINT(STDOUT,' ') 0711.000 CALL PUTC(STDOUT,SPQUOTE) 0712.000 CALL PRINTL(STDOUT,' Start-of-Packet: ') 0713.000 CALL PUTC(STDOUT,ICHAR('^')) 0714.000 CALL PUTC(STDOUT,CTL(SYNC)) 0715.000 CALL PRINT(STDOUT,' ') 0716.000 CALL PUTC(STDOUT,ICHAR('^')) 0717.000 CALL PUTC(STDOUT,CTL(SNDSYNC)) 0718.000 C 0719.000 C display protocol stuff 0720.000 C 0721.000 CALL PRINTL(STDOUT,'Delay before sending first packet: ') 0722.000 CALL PUTINT(STDOUT,DELAYFP,1) 0723.000 CALL PRINTL(STDOUT,'Init packet retry count: ') 0724.000 CALL PUTINT(STDOUT,MAXRINI,1) 0725.000 CALL PRINTL(STDOUT,'Packet retry count: ') 0726.000 CALL PUTINT(STDOUT,MAXRTRY,1) 0727.000 CALL PUTC(STDOUT,NEL) 0728.000 RETURN 0729.000 END 0730.000 SUBROUTINE STATUS 0731.000 IMPLICIT NONE 0732.000 C 0733.000 C= Tell how long last transfer took. 0734.000 C 0735.000 INCLUDE K.KERMV 0736.000 INCLUDE K.KERMD 0737.000 INCLUDE K.PROTC 0738.000 INCLUDE K.PACKC 0739.000 INCLUDE K.TIMEC 0740.000 C 0741.000 INTEGER HR,MIN,SEC 0742.000 INTEGER NSEC 0743.000 C 0744.000 LOGICAL CONFIRM 0745.000 C 0746.000 C confirm the command 0747.000 C 0748.000 IF (.NOT. CONFIRM(INPUTFD)) RETURN 0749.000 C 0750.000 CALL PRINTL(STDOUT,'Max characters in packet: ') 0751.000 CALL PUTINT(STDOUT, PACKSIZ, 1) 0752.000 CALL PRINT(STDOUT,' received; ') 0753.000 CALL PUTINT(STDOUT, SPKSIZ, 1) 0754.000 CALL PRINT(STDOUT,' sent') 0755.000 CALL PUTC(STDOUT,NEL) 0756.000 IF (ENDTIM .LT. STARTIM) ENDTIM = ENDTIM + 86400 0757.000 NSEC = ENDTIM - STARTIM 0758.000 HR = NSEC / 3600 0759.000 NSEC = NSEC - (HR * 3600) 0760.000 MIN = NSEC / 60 0761.000 NSEC = NSEC - (MIN * 60) 0762.000 CALL PRINTL(STDOUT,'Number of characters transmitted in ') 0763.000 IF (HR .GT. 0) THEN 0764.000 CALL PUTINT(STDOUT,HR,1) 0765.000 CALL PRINT(STDOUT,' hours ') 0766.000 ENDIF 0767.000 IF (MIN .GT. 0 .OR. HR .GT. 0) THEN 0768.000 CALL PUTINT(STDOUT,MIN,1) 0769.000 CALL PRINT(STDOUT,' minutes ') 0770.000 ENDIF 0771.000 CALL PUTINT(STDOUT,NSEC,1) 0772.000 CALL PRINT(STDOUT,' seconds') 0773.000 CALL PRINTL(STDOUT,' Sent: ') 0774.000 CALL PUTINT(STDOUT, SCHCNT, 20) 0775.000 CALL PRINT(STDOUT,' Overhead: ') 0776.000 CALL PUTINT(STDOUT, SCHOVRH, 1) 0777.000 CALL PRINTL(STDOUT,' Received: ') 0778.000 CALL PUTINT(STDOUT, RCHCNT, 20) 0779.000 CALL PRINT(STDOUT,' Overhead: ') 0780.000 CALL PUTINT(STDOUT, RCHOVRH, 1) 0781.000 CALL PRINTL(STDOUT,'Total Transmitted: ') 0782.000 CALL PUTINT(STDOUT, RCHCNT+SCHCNT, 20) 0783.000 CALL PRINT(STDOUT,' Overhead: ') 0784.000 CALL PUTINT(STDOUT, RCHOVRH+SCHOVRH, 1) 0785.000 CALL PUTC(STDOUT, NEL) 0786.000 CALL PRINTL(STDOUT,'Total characters transmitted per sec: ') 0787.000 CALL PUTINT(STDOUT,(SCHCNT+RCHCNT)/(ENDTIM-STARTIM),1) 0788.000 CALL PRINTL(STDOUT,'Effective data rate: ') 0789.000 CALL PUTINT(STDOUT,((SCHCNT+RCHCNT)-(SCHOVRH+RCHOVRH)) / 0790.000 $ (ENDTIM-STARTIM) * 10, 1) 0791.000 CALL PRINT(STDOUT,' baud') 0792.000 CALL FLUSH(STDOUT) 0793.000 IF (STATE .NE. C) THEN 0794.000 CALL GETEMSG(PACKET) 0795.000 CALL PRINTL(STDOUT,'?Kermit: ') 0796.000 CALL PUTSTR(STDOUT, PACKET) 0797.000 CALL FLUSH(STDOUT) 0798.000 ENDIF 0799.000 C 0800.000 C timing 0801.000 C 0802.000 IF (LOCALON) THEN 0803.000 CALL PRINTL(STDOUT, 'Connect timing averages: ') 0804.000 CALL PRINT(STDOUT, 'GETC ') 0805.000 CALL PUTINT(STDOUT, GETIME/GETCOUNT, 5) 0806.000 CALL PRINT(STDOUT, ' PUTC ') 0807.000 CALL PUTINT(STDOUT, PUTIME/PUTCOUNT, 5) 0808.000 CALL PRINT(STDOUT, ' WAIT ') 0809.000 CALL PUTINT(STDOUT, WAITIME/WAITCNT, 5) 0810.000 CALL PRINT(STDOUT, ' TOTAL ') 0811.000 CALL PUTINT(STDOUT, TOTIME, 5) 0812.000 ENDIF 0813.000 RETURN 0814.000 END 0815.000 SUBROUTINE DBUGCMD 0816.000 IMPLICIT NONE 0817.000 C 0818.000 C= Set the debugging modes. 0819.000 C 0820.000 INCLUDE K.KERMD 0821.000 INCLUDE K.PROTC 0822.000 INCLUDE K.DBUGC 0823.000 C 0824.000 INTEGER DEBUGFN(17) !file name 0825.000 INTEGER TSIZE ;PARAMETER (TSIZE = 5) 0826.000 CHARACTER*10 DBGTYP(TSIZE) 0827.000 $ /'ALL','LOG-FILE','OFF','PACKETS','STATES'/ 0828.000 INTEGER INDX 0829.000 INTEGER IRET 0830.000 C 0831.000 INTEGER MATCH 0832.000 LOGICAL CONFIRM 0833.000 INTEGER OPEN 0834.000 C 0835.000 INDX = MATCH(DBGTYP, TSIZE, .FALSE.) 0836.000 IF (INDX .LE. 0) RETURN 0837.000 GOTO (10, 20, 30, 40 ) INDX 0838.000 C 0839.000 10 CONTINUE !set all debug modes 0840.000 DEBUG = .TRUE. 0841.000 GOTO 100 0842.000 C 0843.000 20 CONTINUE !set logfile 0844.000 CALL SETVAL(DEBUGFN, 'S', IRET, 16, 0, 0, 0845.000 $ 'Debug output logfile specification', .TRUE.) 0846.000 IF (IRET .EQ. OK) THEN 0847.000 CALL AS2DPC(DEBUGFN, DBGFILE) 0848.000 IF (DBGFD .NE. 0) THEN 0849.000 CALL CLOSE(DBGFD) 0850.000 DBGFD = 0 0851.000 ENDIF 0852.000 GOTO 100 0853.000 ENDIF 0854.000 RETURN 0855.000 C 0856.000 30 CONTINUE !turn off all debugging 0857.000 DEBUG = .FALSE. 0858.000 RETURN 0859.000 C 0860.000 40 CONTINUE !toggle debug packets 0861.000 IF (.NOT. CONFIRM(INPUTFD))RETURN 0862.000 DEBUG(DBGPACK) = .NOT. DEBUG(DBGPACK) 0863.000 DEBUG(DBGON) = DEBUG(DBGPACK) .OR. DEBUG(DBGSTAT) 0864.000 DEBUG(DBGSTAT) = .NOT. DEBUG(DBGSTAT) 0865.000 DEBUG(DBGON) = DEBUG(DBGPACK) .OR. DEBUG(DBGSTAT) 0866.000 GOTO 100 0867.000 C 0868.000 100 CONTINUE !open the debug file in not done 0869.000 IF (DBGFD .EQ. 0) THEN 0870.000 DBGFD = OPEN(DBGFILE, 'W') 0871.000 ENDIF 0872.000 RETURN 0873.000 END 0874.000 SUBROUTINE SETPACK(ATTR) 0875.000 IMPLICIT NONE 0876.000 INTEGER ATTR(12) !attributes 0877.000 C 0878.000 C= Set packet send or receive attributes. 0879.000 C 0880.000 C Setpack will wet the attributes of the passed attribute list. 0881.000 C This subroutine will set the appropriate packet parameter. 0882.000 C The parameter to set is passed in an array and is very order 0883.000 C dependent. See common block /packet/ for the ordering. 0884.000 C Note that send and receive parameter ordering and storage 0885.000 C size in the common block are identical. Keep it that way! 0886.000 C 0887.000 INCLUDE K.KERMD 0888.000 C 0889.000 INTEGER TSIZE ;PARAMETER (TSIZE=7) 0890.000 CHARACTER*10 ATTRTYP(TSIZE) !commands 0891.000 $ /'EOL','PACKLEN','PADCHR','PADLEN','QUOTECHR', 0892.000 $ 'SYNCCHR','TIMEOUT'/ 0893.000 INTEGER INDX 0894.000 CHARACTER*63 HLPASCH/ 0895.000 $'Decimal, octal (O), or hexidecimal (H) code for ASCII character' 0896.000 $/ 0897.000 C 0898.000 INTEGER MATCH 0899.000 LOGICAL CONFIRM 0900.000 C 0901.000 INDX = MATCH(ATTRTYP, TSIZE, .FALSE.) 0902.000 IF (INDX .LE. 0) RETURN 0903.000 GOTO (10, 20, 30, 40, 50, 60, 70) INDX 0904.000 C 0905.000 10 CONTINUE !set eol character 0906.000 CALL SETVAL(ATTR(5), 'I',1,31,127,127,HLPASCH,.TRUE.) 0907.000 RETURN 0908.000 C 0909.000 20 CONTINUE !set maximum packet length 0910.000 CALL SETVAL(ATTR(1), 'I',20,1000,20,1000, 0911.000 $ 'Maximum packet length', .TRUE.) 0912.000 RETURN 0913.000 C 0914.000 30 CONTINUE !set pad character 0915.000 CALL SETVAL(ATTR(4), 'I', 0, 31, 127, 127, HLPASCH, .TRUE.) 0916.000 RETURN 0917.000 C 0918.000 40 CONTINUE !set pad length 0919.000 CALL SETVAL(ATTR(3), 'I', 0, 1000, 0, 1000, 0920.000 $ 'Number of pad characters to use', .TRUE.) 0921.000 RETURN 0922.000 C 0923.000 50 CONTINUE !set quote character 0924.000 CALL SETVAL(ATTR(6), 'I',33, 62, 97, 126, HLPASCH, .TRUE.) 0925.000 RETURN 0926.000 C 0927.000 60 CONTINUE !set sync character 0928.000 CALL SETVAL(ATTR(12),'I', 0,127, 0, 127, HLPASCH, .TRUE.) 0929.000 RETURN 0930.000 C 0931.000 70 CONTINUE !set timeout value 0932.000 CALL SETVAL(ATTR(2), 'I', 0, 1000, 0, 1000, 0933.000 $ 'Number of seconds to wait before timeout', .TRUE.) 0934.000 RETURN 0935.000 END 0936.000 SUBROUTINE PORTCMD 0937.000 IMPLICIT NONE 0938.000 C 0939.000 C= Selects the port to be used. 0940.000 C 0941.000 INCLUDE K.KERMD 0942.000 INCLUDE K.PROTC 0943.000 C 0944.000 INTEGER PORTSTR(7) !port string to read 0945.000 CHARACTER*6 PORTNM !char device name 0946.000 CHARACTER*6 PORTWR !write port 0947.000 INTEGER IRET !error code 0948.000 INTEGER INEW !new input 0949.000 INTEGER ONEW !new output 0950.000 C 0951.000 INTEGER OPEN !open port 0952.000 INTEGER XTOI !hex ascii to integer 0953.000 CHARACTER*4 ITOX !integer to hex ascii 0954.000 C 0955.000 CALL SETVAL(PORTSTR, 'S', IRET, 6, 0, 0, 0956.000 $ 'Select communication port', .TRUE.) 0957.000 IF (IRET .EQ. OK) THEN 0958.000 CALL AS2DPC(PORTSTR, PORTNM) 0959.000 C 0960.000 IF (PORTNM .EQ. COMPORT) THEN !ignore no change 0961.000 ELSE 0962.000 C 0963.000 C now open 0964.000 C 0965.000 IF (PORTNM .EQ. 'UT') THEN 0966.000 IF (IFD .NE. STDIN) CALL CLOSE(IFD) 0967.000 IF (OFD .NE. STDOUT) CALL CLOSE(OFD) 0968.000 IFD = STDIN 0969.000 OFD = STDOUT 0970.000 COMPORT = PORTNM 0971.000 ELSE 0972.000 INEW = OPEN('@'//PORTNM,'R') 0973.000 IF (INEW .LE. 0) THEN 0974.000 CALL PRINTL(STDOUT, 'Failed to open read channel, code= ')0975.000 CALL PUTINT(STDOUT, -INEW, 3) 0976.000 RETURN 0977.000 ENDIF 0978.000 PORTWR = PORTNM(1:2) 0979.000 PORTWR(3:6) = ITOX(XTOI(PORTNM(3:6))+8) 0980.000 ONEW = OPEN('@'//PORTWR,'W') 0981.000 IF (ONEW .LE. 0) THEN 0982.000 CALL CLOSE(INEW) 0983.000 CALL PRINTL(STDOUT,'Failed to open write channel,code= ') 0984.000 CALL PUTINT(STDOUT, -ONEW, 3) 0985.000 RETURN 0986.000 ENDIF 0987.000 IF (IFD .NE. STDIN) CALL CLOSE(IFD) 0988.000 IF (OFD .NE. STDOUT) CALL CLOSE(OFD) 0989.000 COMPORT = PORTNM 0990.000 IFD = INEW 0991.000 OFD = ONEW 0992.000 ENDIF 0993.000 ENDIF 0994.000 ENDIF 0995.000 RETURN 0996.000 END 0997.000 SUBROUTINE CONNECT 0998.000 IMPLICIT NONE 0999.000 C 1000.000 C= Connects stdin/stdout to in/out port 1001.000 C 1002.000 INCLUDE K.KERMD 1003.000 INCLUDE K.PROTC 1004.000 INCLUDE K.TIMEC 1005.000 C 1006.000 INTEGER BELL ;PARAMETER (BELL = X'07') 1007.000 INTEGER ZERO ;PARAMETER (ZERO = X'30') 1008.000 INTEGER BREAK ;PARAMETER (BREAK = X'42') 1009.000 INTEGER CLOSE ;PARAMETER (CLOSE = X'43') 1010.000 INTEGER QUIT ;PARAMETER (QUIT = X'51') 1011.000 INTEGER RESUME ;PARAMETER (RESUME=X'52') 1012.000 INTEGER LOWA ;PARAMETER (LOWA = X'61') 1013.000 INTEGER LOWZ ;PARAMETER (LOWZ = X'7A') 1014.000 INTEGER LOW2UP ;PARAMETER (LOW2UP = X'20') 1015.000 INTEGER INCHR !char from stdin 1016.000 INTEGER TTCHR !char from port 1017.000 CHARACTER*10 CNUM !character 1018.000 CHARACTER*10 CNUM2 1019.000 INTEGER STIME 1020.000 INTEGER FTIME 1021.000 CLT LOGICAL PAUSER !XXX 1022.000 CLT LOGICAL DUMPER !XXX 1023.000 C 1024.000 INTEGER GETC !get character 1025.000 LOGICAL CONFIRM !confirm connect 1026.000 INTEGER CTL !convert ctl to non-control 1027.000 CHARACTER*(*)ITOA 1028.000 CLT LOGICAL OPTION !XXX 1029.000 C 1030.000 IF (.NOT. CONFIRM(INPUTFD)) RETURN 1031.000 CLT PAUSER = OPTION (1) !XXX 1032.000 CLT DUMPER = OPTION (2) !XXX 1033.000 C 1034.000 IF (IFD .EQ. STDIN .OR. OFD .EQ. STDOUT) THEN 1035.000 CALL PRINTL(STDOUT, '?No external port selected.') 1036.000 RETURN 1037.000 ENDIF 1038.000 C 1039.000 CALL PUTC(STDOUT, NEL) 1040.000 CALL PRINT(STDOUT, '[Connecting to port, type ^') 1041.000 CALL PUTC(STDOUT, CTL(ESCCHR)) 1042.000 CALL PRINT(STDOUT, ' C to return to local]') 1043.000 CALL PUTC(STDOUT, NEL) 1044.000 CALL PUTC(STDOUT, NEL) 1045.000 C 1046.000 CALL STTY(STDIN, 'BINARY', ON) 1047.000 CALL STTY(STDIN, 'SIZE', 1) 1048.000 CALL STTY(STDOUT, 'SIZE', 1) 1049.000 CALL STTY(STDIN, 'NOWAIT', ON) 1050.000 CALL STTY(STDOUT, 'NOWAIT', ON) 1051.000 CALL STTY(IFD, 'BINARY', ON) 1052.000 CALL STTY(IFD, 'SIZE', 1) 1053.000 CALL STTY(OFD, 'SIZE', 1) 1054.000 CALL STTY(IFD, 'NOWAIT', ON) 1055.000 CALL STTY(OFD, 'NOWAIT', ON) 1056.000 GETIME = PUTIME = 0 1057.000 GETCOUNT = PUTCOUNT = 0 1058.000 WAITIME = WAITCNT = 0 1059.000 CALL MSEC(TOTIME) 1060.000 C 1061.000 DO BEGIN 1062.000 CLT IF (DUMPER) CALL DUMPF('BEGIN') !XXX 1063.000 CLT IF (PAUSER) PAUSE BEGIN !XXX 1064.000 CALL MSEC(STIME) 1065.000 INCHR = GETC(STDIN, INCHR) 1066.000 CALL MSEC(FTIME) 1067.000 CLT IF (DUMPER) CALL DUMPF('AFTER STDIN') !XXX 1068.000 GETCOUNT = GETCOUNT + 1 1069.000 GETIME = FTIME - STIME + GETIME 1070.000 CALL MSEC(STIME) 1071.000 TTCHR = GETC(IFD, TTCHR) 1072.000 CALL MSEC(FTIME) 1073.000 GETCOUNT = GETCOUNT + 1 1074.000 GETIME = FTIME - STIME + GETIME 1075.000 C 1076.000 CLT IF (INCHR .NE. ERROR .OR. TTCHR .NE. ERROR) THEN 1077.000 CLT CNUM = ITOA(INCHR) 1078.000 CLT CNUM2 = ITOA(TTCHR) 1079.000 CLT CALL DISPLAY('KERMIT/CONNECT - PARSE CHARACTER'//CNUM//CNUM2) 1080.000 CLT ENDIF 1081.000 IF (INCHR .EQ. EOF) THEN 1082.000 CLT CALL DISPLAY('KERMIT/CONNECT - EOF') 1083.000 LEAVE 1084.000 ELSE IF (INCHR .EQ. ERROR) THEN 1085.000 CONTINUE 1086.000 ELSE IF (INCHR .EQ. ESCCHR) THEN 1087.000 10 CONTINUE 1088.000 CLT CALL DISPLAY('KERMIT/CONNECT - WAIT FOR NON-ERROR') 1089.000 DO WHILE (GETC(STDIN, INCHR) .EQ. ERROR) 1090.000 CALL IOWAIT(50 ) 1091.000 ENDDO 1092.000 IF (INCHR .GE. LOWA .AND. INCHR .LE. LOWZ) 1093.000 $ INCHR = INCHR - LOW2UP 1094.000 CNUM = ITOA(INCHR) 1095.000 CLT CALL DISPLAY('KERMIT/CONNECT - NON-ERROR ='//CNUM) 1096.000 IF (INCHR .EQ. CLOSE) THEN 1097.000 LEAVE 1098.000 ELSE IF (INCHR .EQ. BREAK) THEN 1099.000 CALL SENDBRK(OFD) 1100.000 ELSE IF (INCHR .EQ. ZERO) THEN 1101.000 CALL PUTC(OFD, 0) 1102.000 ELSE IF (INCHR .EQ. QUIT) THEN 1103.000 LOG = .FALSE. 1104.000 ELSE IF (INCHR .EQ. RESUME) THEN 1105.000 IF (FFD .NE. 0) LOG = .TRUE. 1106.000 ELSE IF (INCHR .EQ. ESCCHR) THEN 1107.000 CALL PUTC(OFD, ESCCHR) 1108.000 ELSE IF (INCHR .EQ. QMARK) THEN 1109.000 CALL STTY(STDOUT, 'SIZE', -1) 1110.000 CALL STTY(STDOUT, 'NOWAIT', OFF) 1111.000 CALL PRINTL(STDOUT,'0 Send NULL') 1112.000 CALL PRINTL(STDOUT,'B Send BREAK') 1113.000 CALL PRINTL(STDOUT,'C Close connection') 1114.000 CALL PRINTL(STDOUT,'Q Quit logging') 1115.000 CALL PRINTL(STDOUT,'R Resume logging') 1116.000 CALL PUTC(STDOUT, NEL) 1117.000 CALL PRINT(STDOUT, '^') 1118.000 CALL PUTC(STDOUT, CTL(ESCCHR)) 1119.000 CALL PRINT(STDOUT,' Send this character') 1120.000 CALL PRINTL(STDOUT,'? This message') 1121.000 CALL PRINTL(STDOUT,'Command>') 1122.000 CALL STTY(STDOUT, 'NOWAIT', ON) 1123.000 CALL STTY(STDOUT, 'SIZE', 1) 1124.000 GOTO 10 1125.000 ELSE 1126.000 CALL PUTC(STDOUT, BELL) 1127.000 ENDIF 1128.000 ELSE 1129.000 CLT CALL DISPLAY('KERMIT/CONNECT - PUTC OFD') 1130.000 CALL MSEC(STIME) 1131.000 CALL PUTC(OFD, INCHR) 1132.000 CALL MSEC(FTIME) 1133.000 PUTCOUNT = PUTCOUNT + 1 1134.000 PUTIME = PUTIME + FTIME - STIME 1135.000 IF (ECHO) CALL PUTC(STDOUT, INCHR) 1136.000 ENDIF 1137.000 C 1138.000 IF (TTCHR .EQ. EOF) THEN 1139.000 CALL PRINTL(STDOUT, '?EOF on port connection') 1140.000 LEAVE 1141.000 ELSE IF (TTCHR .EQ. ERROR) THEN 1142.000 CONTINUE 1143.000 ELSE 1144.000 CLT CALL DISPLAY('KERMIT/CONNECT - PUTC STDOUT') 1145.000 CALL MSEC(STIME) 1146.000 CALL PUTC(STDOUT, TTCHR) 1147.000 CALL MSEC(FTIME) 1148.000 PUTIME = PUTIME + FTIME - STIME 1149.000 PUTCOUNT = PUTCOUNT + 1 1150.000 IF (LOG) THEN 1151.000 IF (TTCHR .GE. BLANK .AND. TTCHR .LT. DEL) THEN 1152.000 CALL PUTC(LFD, TTCHR) 1153.000 ELSE IF (TTCHR .EQ. CR) THEN 1154.000 CALL PUTC(LFD, NEL) 1155.000 ENDIF 1156.000 ENDIF 1157.000 ENDIF 1158.000 C 1159.000 CALL MSEC(STIME) 1160.000 IF (TTCHR .EQ. ERROR .AND. INCHR .EQ. ERROR) THEN 1161.000 CALL IOWAIT(50 ) 1162.000 ENDIF 1163.000 CALL MSEC(FTIME) 1164.000 WAITIME = WAITIME + FTIME - STIME 1165.000 WAITCNT = WAITCNT + 1 1166.000 C 1167.000 ENDDO 1168.000 CLT IF (DUMPER) CALL DUMPF('ENDDO') !XXX 1169.000 CLT IF (PAUSER) PAUSE ENDDO !XXX 1170.000 C 1171.000 CALL MSEC(FTIME) 1172.000 TOTIME = FTIME - TOTIME 1173.000 CALL FLUSH(IFD) 1174.000 CALL FLUSH(STDIN) 1175.000 CALL STTY(STDIN, 'BINARY', OFF) 1176.000 CALL STTY(STDIN, 'SIZE', 80) 1177.000 CALL STTY(STDOUT, 'SIZE', -1) 1178.000 CALL STTY(STDIN, 'NOWAIT', OFF) 1179.000 CALL STTY(STDOUT, 'NOWAIT', OFF) 1180.000 CALL STTY(IFD, 'BINARY', OFF) 1181.000 CALL STTY(IFD, 'SIZE', -1) 1182.000 CALL STTY(OFD, 'SIZE', -1) 1183.000 CALL STTY(IFD, 'NOWAIT', OFF) 1184.000 CALL STTY(OFD, 'NOWAIT', OFF) 1185.000 CLT IF (DUMPER) CALL DUMPF('EXIT CONNECT') !XXX 1186.000 C 1187.000 RETURN 1188.000 END 1189.000 SUBROUTINE LOGGER 1190.000 IMPLICIT NONE 1191.000 C 1192.000 C= Performs log command 1193.000 C 1194.000 INCLUDE K.KERMD 1195.000 INCLUDE K.PROTC 1196.000 C 1197.000 INTEGER NCMD ;PARAMETER (NCMD = 3) 1198.000 CHARACTER*8 CMD(NCMD) 1199.000 $ /'LOG-FILE', 'OFF', 'ON'/ 1200.000 INTEGER IRET 1201.000 INTEGER TSTR(17) !temp file string 1202.000 INTEGER INDX 1203.000 C 1204.000 INTEGER MATCH 1205.000 INTEGER OPEN !open file 1206.000 C 1207.000 INDX = MATCH(CMD, NCMD, .FALSE.) 1208.000 IF (INDX .LE. 0) RETURN 1209.000 C 1210.000 GOTO (10, 20, 30) INDX 1211.000 C 1212.000 10 CONTINUE 1213.000 CALL SETVAL(TSTR, 'S', IRET, 16, 0, 0, 1214.000 $ 'Session log filename', .TRUE.) 1215.000 IF (IRET .EQ. OK) THEN 1216.000 CALL AS2DPC(TSTR, LOGFILE) 1217.000 LFD = OPEN(LOGFILE, 'W') 1218.000 IF (LFD .LE. 0) THEN 1219.000 CALL PRINTL(STDOUT, '?Failed to open session log file ') 1220.000 CALL PUTINT(STDOUT, -LFD, 3) 1221.000 LOG = .FALSE. 1222.000 ELSE 1223.000 LOG = .TRUE. 1224.000 ENDIF 1225.000 ENDIF 1226.000 GOTO 100 1227.000 C 1228.000 20 CONTINUE 1229.000 LOG = .FALSE. 1230.000 IF (LFD .GT. 0) CALL CLOSE(LFD) 1231.000 GOTO 100 1232.000 C 1233.000 30 CONTINUE 1234.000 IF (LFD .EQ. 0) THEN 1235.000 LFD = OPEN(LOGFILE, 'W') 1236.000 IF (LFD .EQ. ERROR) 1237.000 $ CALL PRINTL(STDOUT, '?Failed to open session log file') 1238.000 ENDIF 1239.000 LOG = LFD .GT. 0 1240.000 GOTO 100 1241.000 C 1242.000 100 CONTINUE 1243.000 RETURN 1244.000 END 1245.000 SUBROUTINE FINISH 1246.000 IMPLICIT NONE 1247.000 C 1248.000 C= Sends finish command to target port 1249.000 C 1250.000 INCLUDE K.KERMD 1251.000 INCLUDE K.PROTC 1252.000 INCLUDE K.PACKC 1253.000 C 1254.000 INTEGER PTYP, LEN, NUM 1255.000 C 1256.000 LOGICAL CONFIRM 1257.000 INTEGER RDPACK 1258.000 C 1259.000 IF (.NOT. CONFIRM(INPUTFD)) RETURN 1260.000 C 1261.000 IF (IFD .EQ. STDIN ) THEN 1262.000 CALL PRINTL(STDOUT, '?No communication port selected.') 1263.000 RETURN 1264.000 ENDIF 1265.000 C 1266.000 CALL STTY(IFD, 'BINARY', ON) 1267.000 CALL STTY(IFD, 'TIMEOUT', TIMEOUT) 1268.000 CALL STTY(IFD, 'NOWAIT', ON) 1269.000 NUMTRY = 0 1270.000 PACKET(1) = F !f is constant , fort codes as halfw.1271.000 DO WHILE (NUMTRY .LE. MAXTRY) 1272.000 NUMTRY = NUMTRY + 1 1273.000 CALL SNDPACK(G, 0, 1, PACKET) 1274.000 PTYP = RDPACK(LEN, NUM, RECPACK) 1275.000 IF (PTYP .EQ. Y) LEAVE 1276.000 ENDDO 1277.000 CALL STTY(IFD, 'NOWAIT', OFF) 1278.000 CALL STTY(IFD, 'TIMEOUT', 0) 1279.000 CALL STTY(IFD, 'BINARY', OFF) 1280.000 RETURN 1281.000 END 1282.000 SUBROUTINE BYE 1283.000 IMPLICIT NONE 1284.000 C 1285.000 C= Sends bye to remote and exits kermit 1286.000 C 1287.000 INCLUDE K.KERMD 1288.000 INCLUDE K.PROTC 1289.000 INCLUDE K.PACKC 1290.000 C 1291.000 1292.000 INTEGER PTYP !packet type 1293.000 INTEGER LEN, NUM 1294.000 C 1295.000 LOGICAL CONFIRM 1296.000 INTEGER RDPACK 1297.000 C 1298.000 IF (.NOT. CONFIRM(INPUTFD)) RETURN 1299.000 C 1300.000 CALL STTY(IFD, 'BINARY', ON) 1301.000 CALL STTY(IFD, 'TIMEOUT', TIMEOUT) 1302.000 CALL STTY(IFD, 'NOWAIT', ON) 1303.000 IF (IFD .EQ. STDIN ) THEN 1304.000 CALL PRINTL(STDOUT, '?No communication port selected.') 1305.000 RETURN 1306.000 END IF 1307.000 C 1308.000 PACKET(1) = L 1309.000 NUMTRY = 0 1310.000 DO WHILE (NUMTRY .LE. MAXTRY) 1311.000 NUMTRY = NUMTRY + 1 1312.000 CALL SNDPACK(G, 0, 1, PACKET) 1313.000 PTYP = RDPACK(LEN, NUM, RECPACK) 1314.000 IF (PTYP .EQ. Y) LEAVE 1315.000 ENDDO 1316.000 CALL STTY(IFD, 'NOWAIT', OFF) 1317.000 CALL STTY(IFD, 'TIMEOUT', 0) 1318.000 CALL STTY(IFD, 'BINARY', OFF) 1319.000 CALL EXITPGM 1320.000 END 1321.000 SUBROUTINE GETFROM 1322.000 IMPLICIT NONE 1323.000 C 1324.000 C= Get file from remote server 1325.000 C 1326.000 INCLUDE K.KERMD 1327.000 INCLUDE K.PROTC 1328.000 INCLUDE K.PACKC 1329.000 C 1330.000 INTEGER IRET !return status 1331.000 INTEGER PTYP !packet type 1332.000 INTEGER LEN 1333.000 INTEGER NUM 1334.000 C 1335.000 INTEGER SLEN !length of string 1336.000 INTEGER RECEIVE 1337.000 INTRINSIC MOD 1338.000 INTEGER RDPACK !read packet 1339.000 INTEGER SNDPAR !pack send parameters 1340.000 C 1341.000 CALL SETVAL(FILESTR, 'S', IRET, 16, 0, 0, 1342.000 $ 'Filename to get', .TRUE.) 1343.000 IF (IRET .EQ. ERROR) RETURN 1344.000 C 1345.000 IF (IFD .EQ. STDIN) THEN 1346.000 CALL PRINTL(STDOUT, '?No communication port selected.') 1347.000 RETURN 1348.000 END IF 1349.000 C 1350.000 IF (INPUTFD .NE. STDIN .AND. OFD .NE. STDOUT) THEN 1351.000 CALL PRINTL(STDOUT, 'Getting file ') 1352.000 CALL PUTSTR(STDOUT, FILESTR) 1353.000 CALL FLUSH(STDOUT) 1354.000 ENDIF 1355.000 C 1356.000 CALL STTY(IFD, 'BINARY', ON) 1357.000 CALL STTY(IFD, 'TIMEOUT', TIMEOUT) 1358.000 CALL STTY(IFD, 'NOWAIT', ON) 1359.000 C 1360.000 NUMTRY = 0 1361.000 DO WHILE (NUMTRY .LE. MAXRINI) 1362.000 NUMTRY = NUMTRY + 1 1363.000 CALL SNDPACK(R, 0, SLEN(FILESTR), FILESTR) 1364.000 PTYP = RDPACK(LEN, NUM, RECPACK) 1365.000 IF (PTYP .EQ. S) THEN 1366.000 PACKNUM = NUM 1367.000 CALL RDPARAM(RECPACK) 1368.000 LEN = SNDPAR(PACKET) 1369.000 CALL SNDPACK(Y, PACKNUM, LEN, PACKET) 1370.000 NUMTRY = 0 1371.000 PACKNUM = MOD(PACKNUM+1, 64) 1372.000 IF (RECEIVE(F) .EQ. OK) THEN 1373.000 CALL PRINTL(STDOUT, 'Receive complete.') 1374.000 ELSE 1375.000 CALL PRINTL(STDOUT, 'Receive failed.') 1376.000 ENDIF 1377.000 LEAVE 1378.000 ENDIF 1379.000 ENDDO 1380.000 CALL STTY(IFD, 'NOWAIT', OFF) 1381.000 CALL STTY(IFD, 'TIMEOUT', 0) 1382.000 CALL STTY(IFD, 'BINARY', OFF) 1383.000 RETURN 1384.000 END 1385.000 SUBROUTINE TAKE 1386.000 IMPLICIT NONE 1387.000 C 1388.000 C Provides a means to redirect input to file. 1389.000 C 1390.000 INCLUDE K.KERMD 1391.000 INCLUDE K.PROTC 1392.000 C 1393.000 INTEGER TAKEFILE(17) !take file input name 1394.000 CHARACTER*8 CTAKEFIL !input file name 1395.000 INTEGER IRET !return code 1396.000 INTEGER TAKEFD !file desc to take from 1397.000 C 1398.000 LOGICAL ISFILE !check for file existence 1399.000 INTEGER OPEN 1400.000 C 1401.000 C 1402.000 CALL SETVAL(TAKEFILE, 'S', IRET, 16, 0, 0, 1403.000 $ 'Filename to take commands from',.TRUE.) 1404.000 IF (IRET .EQ. ERROR) RETURN 1405.000 C 1406.000 C check to make sure it's there 1407.000 C 1408.000 CALL AS2DPC(TAKEFILE, CTAKEFIL) 1409.000 IF (.NOT. ISFILE(CTAKEFIL)) THEN 1410.000 CALL PRINTL(STDOUT, '?File ') 1411.000 CALL PUTSTR(STDOUT, TAKEFILE) 1412.000 CALL PRINT(STDOUT, ' is not found.') 1413.000 CALL PUTC(STDOUT, NEL) 1414.000 RETURN 1415.000 ENDIF 1416.000 C 1417.000 C open file 1418.000 C 1419.000 IF (INSTACK .GE. MAXINSTK) THEN 1420.000 CALL PRINTL(STDOUT, '?Exceed input TAKE stack depth.') 1421.000 RETURN 1422.000 ENDIF 1423.000 TAKEFD = OPEN(CTAKEFIL, 'R') 1424.000 IF (TAKEFD .EQ. ERROR) THEN 1425.000 CALL PRINTL(STDOUT, '?Cannot open ') 1426.000 CALL PUTSTR(STDOUT, TAKEFILE) 1427.000 CALL PRINT(STDOUT, '.') 1428.000 CALL PUTC(STDOUT, NEL) 1429.000 RETURN 1430.000 ENDIF 1431.000 C 1432.000 C remember where was 1433.000 C 1434.000 INSTACK = INSTACK + 1 1435.000 INSTKFD(INSTACK) = INPUTFD 1436.000 C 1437.000 C redirect 1438.000 C 1439.000 INPUTFD = TAKEFD 1440.000 RETURN 1441.000 END 1442.000 SUBROUTINE TAKEDONE 1443.000 IMPLICIT NONE 1444.000 C 1445.000 C= Returns to next level of input file. 1446.000 C 1447.000 INCLUDE K.KERMD 1448.000 INCLUDE K.PROTC 1449.000 C 1450.000 IF (INPUTFD .NE. STDIN) CALL CLOSE(INPUTFD) 1451.000 IF (INSTACK .LE. 0) THEN 1452.000 INSTACK = 0 1453.000 INPUTFD = STDIN 1454.000 ELSE 1455.000 INPUTFD = INSTKFD(INSTACK) 1456.000 INSTACK = INSTACK - 1 1457.000 ENDIF 1458.000 RETURN 1459.000 END 1460.000