$NLIST C------------------------------------------------------------------- PROGRAM Kermit ; (Celtic for 'free') C C................................................................... C Kermit-CO Version 2.1 4/16/86 C C -- Configured for the CONCURRENT Computer Corp. 3200 series C under OS/32, Rev. 7.2 and up, by: C C Paul Mamelka C Genetics Department C Southwest Foundation for Biomedical Research C Box 28147 C San Antonio, TX (512) 674-1410 C C -- Current versions are available through INTERCHANGE library, C and Columbia University C C -- Other contributors to the Kermit kause include David MacPhee, C Tom Funke, John Cooley, Rick MacDonald, and Walter Shevchuk. C................................................................... C C -- Kermit-CO is a revised, and much expanded, version of a Kermit C written for the Hewlett-Packard 1000: c C RTE-6/VM KERMIT, implemented by John Lee of RCA Laboratories C C Permission is granted to any individual or institution to copy C or use this program, except for explicitly commerical purpose. C C John Lee 6/29/84 C RCA Laboratories C (609) 734-3157 C............................................................. C ** Kermit-CO Release Files** C C CONKER.DOC - Documentation C C CONKER.FTN - Fortran source (rename to KERMIT.FTN for use) C C CONKER.ETC - a collection of following files: C C KERMLINK.CSS - Link file with XSVC1 option C KERMIT.CSS - Run time Command file C KERMIT.HLP - Help file of KERMIT-CO commands C KERDEF, KERCOM - INCLUDE files of COMMON, PARAMETERs C.............................................................. C ** Logical Unit Assignments** C C 1 : Comm. Input (LOCAL/RMTINFD) (CSS assigned) C 2 : Comm. Output (LOCAL/RMTOUTFD) (CSS assigned) C 3 - 12 : Transfer, Directory, Scratch files (BUFFCHAN) C 15 : Help file KERMIT.HLP (CSS assigned) C 16 : Initial Settings: KERMIT.INI or User-specified in CSS C 20 : Session log file KERMIT.LOG C................................................................... $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST COMMON /IOUNIT/ PT,BUFFCHAN(20), RECLCHAN(20),MAXCHAN COMMON /MUX/ VRAWCOOK,VPARITY,VPORT,VBAUD,VENQACK,VXONXOFF,VREST INTEGER*2 STATUS,GETLIN,FCHAN,ITEMP INTEGER ISZ, LUN, TskCode CHARACTER Day6*6,Time6*6,Day8*8,Time8*8 C----------------------------------------------------------------- C Kermit-CO Parameter Initialization C---------------------------------------------------------------- DELAY=10 ; 10 Secs wait before Init packet sent EOL=13 ; CR ESCHAR=29 ; CNTR-] HOSTON=YES ; we are running in Remote Host mode LOCALINFD=1 ; LU 1 for Communiation port Input LOCALOUTFD=2 ; LU 2 for Communication port Output LOCALSLU=1 ; System MAXTRY=5 MYEOL=13 MYPAD=0 ; 0 pads in front of Incoming Packet MYPCHAR=0 ; Null(00), Del(127) , or 255 (OS/32 Pad) MYTIMOUT=10 ;Timeout after 10 secs (Not Implemented) MYQUOTE=35 ; '#' used for Control Char Prefix MYQUOT8B=YES ; Default to 8-bit prefixing with EVEN parity PAD=0 PADCHAR=0 PAKSIZ=94 ;Busy systems like smaller packet size PARITY=5 ;(1=EVEN,2=ODD,3=SPACE,4=MARK,5=NONE) QUOTE=35 QUOT8B=NO ; Set 'No 8-Bit prefixing' as starting REMOTE default SOH=1 STATE=BIGC DEBUGON=NO FMode = TXTFILE ; Default to FORMATTED/TEXT file mode TMode = TXTFILE ; Default to FORMATTED/TEXT for 7 bit path IF (PARITY.EQ.5) TMode = BINFILE ; IMAGE I/O if 8bit path FNamChek=YES ; Set for Make Unique Filename FNamChng=NO ; Set to 'No Names Changed' to start SendEOR=3 ; Delimit Outgoing records with CRLF (13,10) C...........................Following 'To-Be-Installed' ...... SPEED=9600 ;9600 BAUD (Currently Unused: 3/85) IBMON=NO PROMPT=17 ;DC1, IBM MODE ONLY C.............................................................. C Parameters used by Kermit.CO in Local Mode C (as of 1/31/85, only Remote Mode is available) C............................................................. C SET DEFAULT NON-LOGIN TTY ( IN LOCAL MODE ONLY) RMTTTY(1)=BIGA RMTTTY(2)=BIGB RMTTTY(3)=BIGC RMTTTY(4)=BIGD RMTTTY(5)=BIGE RMTTTY(6)=BIGF RMTTTY(7)=LF RMTTTY(8)=EOS SPARITY=YES SBAUD=YES SPORT=NO C VREST=52004B ;7 bits/char; baud rate generaor 1;1 stop bits C VRAWCOOK=400B ;set tty to cook mode VXONXOFF=1 ;set XON/XOFF enabled VENQACK=0 ;set ENQ/ACK disabled C------------------------------------------------------------------- C **Kermit Mainline** C C ..........................Initialize channel stack MAXCHAN=20 PT=1 FCHAN=LOCALOUTFD ; First Channel - 1 = Next LU DO 10 I=PT,MAXCHAN BUFFCHAN(I)=FCHAN+I RECLCHAN(I) = 80 ;Default Rec Size(used by LU 15,16) 10 CONTINUE C ...........................Assume LU 1, LU 2 opened in CSS LUN = LOCALOUTFD CALL DATETIME(Day6,Time6,Day8,Time8) WRITE(LUN,99) IF (HOSTON.EQ.YES) THEN WRITE(LUN,100) Day8,Time8 ELSE WRITE(LUN,110) Day8,Time8 ENDIF RMTINFD=LOCALINFD RMTOUTFD=LOCALOUTFD OPEN(20,FILE='KERMIT.LOG',STATUS='RENEW',RECL=132) C .................................Ready to do business CALL PARSER ;Interpret, route Kermit commands C..................................EXIT/QUIT entered CALL DATETIME(Day6,Time6,Day8,Time8) WRITE(LUN,200) Day8,Time8 INQUIRE(20,SIZE=ISZ) IF (ISZ.LE.0) THEN CLOSE(20,STATUS='DELETE') ; Remove LOG if empty ELSE CLOSE(20) ; Keep if not ENDIF TskCode = 0 ; Good End-0f-Task CALL EXIT(TskCode) ; Au revoir to Kermie.... C.......................................................... 99 FORMAT(/' <><><> CCC OS/32 <><><> Kermit 2.1 <><><>') 100 FORMAT(/3X,'REMOTE Host in effect -> ',A8,2X,A8) 110 FORMAT(/3X,'LOCAL mode in effect --> ',A8,2X,A8) 200 FORMAT(/3X,'Kermit signing off ----> ',A8,2X,A8) END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION AOPEN(FileMode,FNAME,MODE) C C Assigns 'Channel' numbers (logical units) to all files used C for I/O by Kermit. C -- Files are Formatted (TXTFILE) or Unformatted (BINFILE) C depending on 'FileMode'. C -- If a filename to be RECEIVEd already exists, a unique name C is derived (if the user has requested), by adding a C sequential numeric suffix (.001, .002, ... etc.) to the C existing name. C C PM 4/9/86 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 FNAME(1),MODE,TFILE(132),MAXLEN,COUNT INTEGER*2 X,Y,XREAD,XWRITE,IOS,GETCHAN,FileMode INTEGER RECLEN,UserRecL,NSects,ISIZE,LUN,IBLKSZ,MAXBLKSZ PARAMETER (MAXBLKSZ=256) ; Maximum Physical block OS files CHARACTER*12 MyFile LOGICAL TOBE,MAKEUNIQ INTEGER*2 PT,BUFFCHAN(20),RECLCHAN(20),MAXCHAN COMMON /IOUNIT/ PT,BUFFCHAN, RECLCHAN,MAXCHAN COMMON /XBYTE/ XNEW,XCOUNT,XLIN(264),XEOF COMMON /NEWREC/ UserRecL,NSects DATA MAXLEN/12/, XREAD/0/, XWRITE/1/ C................................................ LUN=LOCALOUTFD COUNT=1 AOPEN=BAD ; Assume disaster, just for a change C C Get Filename length, prepare for use 20 IF ((FNAME(COUNT).NE.LF).AND. + (FNAME(COUNT).NE.EOS).AND. + (FNAME(COUNT).NE.0)) THEN TFILE(COUNT)=FNAME(COUNT) COUNT=COUNT+1 GOTO 20 ENDIF C IF(COUNT.LE.MAXLEN)THEN ;fill filename with trailing 40 IF (COUNT.LE.MAXLEN) THEN ;blanks TFILE(COUNT)=BLANK COUNT=COUNT+1 GOTO 40 ENDIF ENDIF TFILE(MAXLEN+1)=EOS CALL PACK(TFILE,MyFile) C......................................Open file for READ IF (MODE.EQ.XREAD) THEN X=GETCHAN(Y) ;get a channel IF(X.EQ.BAD)THEN WRITE (LUN,1000) WRITE(20,1000) ; LOG entry RETURN ENDIF TOBE=.FALSE. ; File Attributes? INQUIRE(FILE=MyFile,EXIST=TOBE,SIZE=ISIZE,IOSTAT=IOS) IF (IOS.NE.0) THEN WRITE (LUN,1010) IOS,MyFile WRITE(20,1010) IOS,MyFile ; LOG entry RETURN ENDIF IF (.NOT.TOBE) THEN WRITE(20,*) ' File ',MyFile,' does not exist' CALL PUTCHAN(X) ; Return Channel, exit RETURN ENDIF IF (ISIZE.LE.0) THEN CALL PUTCHAN(X) WRITE (LUN,1020) MyFile WRITE(20,1020) MyFile ; LOG entry RETURN ENDIF IF (FileMode.EQ.TXTFILE) THEN ; TEXT/ASCII/Formatted OPEN(X,FILE=MyFile,STATUS='OLD',FORM='FORMATTED', 1 IOSTAT=IOS,ACCESS='SEQUENTIAL') IF (IOS.EQ.0) THEN INQUIRE(X,RECL=RECLEN,BLOCKSIZE=IBLKSZ) RECLCHAN(X-1)=RECLEN ; Keep Rec Leng for I/O AOPEN=X ; Set to Non-Disastrous return RETURN ELSE WRITE (LUN,1040) IOS,MyFile WRITE(20,1040) IOS,MyFile ;LOG entry CALL PUTCHAN(X) ;Return channel RETURN ENDIF ELSE C Open Binary/Contiguous as Unformatted file OPEN(X,IOSTAT=IOS,FILE=MyFile,STATUS='OLD', 1 FORM='BINARY',ACCESS='SEQUENTIAL') IF (IOS.EQ.0) THEN INQUIRE(X,RECL=RECLEN,BLOCKSIZE=IBLKSZ) RECLCHAN(X-1)=IBLKSZ AOPEN=X ; Set Non-disastrous return ELSE WRITE (LUN,1040) IOS,MyFile ; ERROR CALL PUTCHAN(X) ;Return channel ENDIF RETURN ENDIF ENDIF C.........................................Open file for WRITE IF (MODE.EQ.XWRITE) THEN CALL REMOVE(FNAME) ;remove that file and ignore X=GETCHAN(Y) ;error, get a channel IF(X.EQ.BAD)THEN WRITE (LUN,1000) RETURN ENDIF TOBE=.FALSE. INQUIRE(FILE=MyFile,EXIST=TOBE) ;Filename unique?? IF (TOBE.AND.FNamChek.EQ.YES) THEN IF (MAKEUNIQ(MyFile)) THEN FNamChng=YES ;Flag for later User message ELSE WRITE(LUN,2010) WRITE(20,2010) ;LOG entry RETURN ENDIF ENDIF IF (FileMode.EQ.TXTFILE) THEN OPEN(X,FILE=MyFile,STATUS='RENEW',FORM='FORMATTED', 1 IOSTAT=IOS,RECL=UserRecL,ACCESS='SEQUENTIAL') ELSE IF (FileMode.EQ.BINFILE) THEN IBLKSZ=MAXBLKSZ IF (UserRecL.LT.MAXBLKSZ) IBLKSZ=UserRecL OPEN(X,FILE=MyFile,STATUS='RENEW',FORM='BINARY', 1 RECL=UserRecL,BLOCKSIZE=IBLKSZ,ACCESS='SEQUENTIAL', 2 IOSTAT=IOS) ELSE ; CONTIGUOUS file (.TSK - Special case) IBLKSZ=MAXBLKSZ OPEN(X,FILE=MyFile,STATUS='RENEW',FORM='BINARY', 1 RECL=UserRecL,BLOCKSIZE=IBLKSZ,ACCESS='SEQUENTIAL', 2 IOSTAT=IOS,TYPE='CONTIG',SIZE=NSects) ENDIF ENDIF IF (IOS.EQ.0) THEN RECLCHAN(X-1)=UserRecL ; Store record len AOPEN=X ; Set Non-Disastrous return RETURN ELSE WRITE (LUN,1050) IOS,MyFile WRITE(20,1050) IOS,MyFile ;LOG entry CALL PUTCHAN(X) RETURN ENDIF ENDIF C..............................MODE code check IF (MODE.NE.XREAD.AND.MODE.NE.XWRITE) THEN WRITE (LUN,1060) MODE ENDIF RETURN C......................................................... 1000 FORMAT(/' All channels have been allocated') 1010 FORMAT(/' Open Error ',I3,' on file--> ',A) 1020 FORMAT(/' Requested SEND file is empty-->',A) 1040 FORMAT(/' OPEN/READ error ',I3,' on file-->',A) 1050 FORMAT(/' OPEN/WRITE Error ',I3,' on file-->',A) 1060 FORMAT(/' Invalid read/write mode detected-->',I3) 2010 FORMAT(/' Problem with File ',A,' - MAKEUNIQ') END $NLIST C--------------------------------------------------------------- LOGICAL FUNCTION MAKEUNIQ(FileIN) C C -- Update FileIN with suffix sequence until unique name is derived. C ( .001 -> .999 is the range of possible suffixes) C C 4/2/86 PM C--------------------------------------------------------------- IMPLICIT NONE CHARACTER*12 FileIN,FileOT CHARACTER*3 FSuf CHARACTER*1 Period,Spce INTEGER K,F1,F2,I,MAXTRIAL,PerPos,NTrial LOGICAL TOBE PARAMETER (MAXTRIAL=999) DATA Period/'.'/, Spce/' '/ MAKEUNIQ=.TRUE. ; Assume success DO 50 I=1,8 IF (FileIN(I:I).EQ.Period.OR.FileIN(I:I).EQ.Spce) GOTO 60 50 CONTINUE 60 PerPos = I IF (PerPos.LE.0) THEN MAKEUNIQ=.FALSE. GOTO 999 ENDIF DO 100 NTrial=1,MAXTRIAL ; Try '.001' -> I=NTrial FSuf=ITOC(I,K) FileOT=FileIN(1:(PerPos-1)) // '.000' F2=PerPos+3 F1=F2-K+1 FileOT(F1:F2)=FSuf(1:K) INQUIRE(FILE=FileOT,EXIST=TOBE) IF (.NOT.TOBE) THEN FileIN=FileOT ; Got Unique name GOTO 999 ENDIF 100 CONTINUE ; Else try again MAKEUNIQ=.FALSE. 999 RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE BUFEMP(BUFFER,LEN) C C Write out the content of the buffer out to the receiving disk file C BUFFER - integer array which holds the data C LEN - Number of bytes in BUFFER C C (Updated 4/9/86 - Skip LF only for TEXT files) C PM 1/85 C JL 4/18/84 14:30 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER TT INTEGER*2 BUFFER(132),LEN,CH,CTL,I,T,T2,FLIP8BIT CH=FD ;file descriptor of receiving disk I=1 ;start with the very first charact 100 IF (I.LE.LEN) THEN ;put LEN characters into disk file T=BUFFER(I) ;get the next character from buffer C C Perform 8-bit "un"prefixing if requested IF (MYQUOT8B.EQ.YES) THEN IF (T.EQ.Q8BCHR) THEN I=I+1 T=BUFFER(I) IF (T.EQ.MYQUOTE) THEN I=I+1 T=BUFFER(I) IF ((T.NE.MYQUOTE).AND.(T.NE.Q8BCHR)) T=CTL(T) ENDIF T=FLIP8BIT(T) ELSE IF (T.EQ.MYQUOTE) THEN I=I+1 T=BUFFER(I) IF ((T.NE.MYQUOTE).AND.(T.NE.Q8BCHR)) T=CTL(T) ENDIF ENDIF ELSE IF (T.EQ.MYQUOTE) THEN I=I+1 T=BUFFER(I) T2=IAND(T,127) IF (T2.NE.MYQUOTE) T=CTL(T) ENDIF ENDIF IF (FMode.EQ.TXTFILE) THEN ;For text, exclude LF's IF(T.NE.LF)CALL DPUTCH(T,CH) ;when writing to Receive file ELSE CALL DPUTCH(T,CH) ;For Binary files, write out all chars ENDIF I=I+1 GOTO 100 ENDIF RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION BUFILL(BUFFER) C C Fill up the buffer with bytes from the sending file. C BUFFER is used to stored the data from the sending disk file C C PM 4/86 C JL 4/18/84 14:30 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 I,CTL,DGETCH,BUFFER(132),CH,T,T2,FLIP8BIT INTEGER*2 DGETemp INTEGER TT I=1 CH=FD ;Sending Disk file C Read from file until EOF reached, or Buffer filled 100 DGETemp = DGETCH(T,CH) IF (DGETemp.NE.EOF) THEN IF(T.EQ.LF.AND.DGETemp.EQ.LDELIM) THEN ; End-of-Rec?? IF (SendEOR.EQ.NO) THEN GOTO 100 ;No Delimiter (WORDSTAR,.TSK,.OBJ,.COM,.EXE) ELSE IF (SendEOR.EQ.1) THEN ; CR ?? (Macintosh usage) T=CR ELSE IF (SendEOR.EQ.2) THEN ; LF ?? (Unix) CONTINUE ELSE IF (SendEOR.EQ.3) THEN ; CRLF? (TEXT files) BUFFER(I)=QUOTE I=I+1 BUFFER(I)=CTL(CR) I=I+1 ENDIF ENDIF C Perform 8-Bit prefixing if requested IF (QUOT8B.EQ.YES) THEN ; Do 8-Bit quoting IF (T.GT.DEL) THEN BUFFER(I)=Q8BCHR I=I+1 T=FLIP8BIT(T) ENDIF IF ((T.LT.BLANK).OR.(T.EQ.DEL).OR.(T.EQ.QUOTE).OR. & (T.EQ.Q8BCHR)) THEN BUFFER(I)=QUOTE I=I+1 IF ((T.NE.QUOTE).AND.(T.NE.Q8BCHR)) T=CTL(T) ENDIF ELSE TT=T T2=IAND(TT,127) ;(as done by CP/M Kermit-80) IF (PARITY.NE.5) T=T2 ; Strip bit 8 if Parity Even/Odd IF (T2.LT.BLANK.OR.T2.EQ.QUOTE.OR.T2.EQ.DEL)THEN BUFFER(I)=QUOTE I=I+1 IF (T2.NE.QUOTE) T=CTL(T) ENDIF ENDIF BUFFER(I)=T I=I+1 IF(I.GT.SPSIZADJ)THEN ;read up to spsiz-6 byte from disk BUFILL=I-1 ;Ith byte was read RETURN ENDIF GOTO 100 ENDIF IF(I.LE.1)THEN BUFILL=EOF ;zero byte was read ELSE BUFILL=I-1 ;partial EOF was detected ENDIF RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION DGETCH(XCHAR,CH) C C Get a CHAR from the disk file C C (Updated 4/9/85 - Return EOF only if LF/EOS encountered C PM 4/86 C JL 4/25/84 14:20 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 XCHAR,CH COMMON /XBYTE/ XNEW,XCOUNT,XLIN(264),XEOF INTEGER*2 X,DGETLIN IF(XEOF.EQ.YES)THEN DGETCH=EOF RETURN ENDIF IF(XNEW.EQ.YES)THEN X=DGETLIN(FMode,XLIN,CH) ; Next line from file to SEND IF(X.EQ.EOF)THEN DGETCH=EOF XEOF=YES RETURN ELSE IF(XLIN(1).EQ.LF.AND.XLIN(2).EQ.EOS) THEN ; PM 4/9/86 XNEW=YES DGETCH=LDELIM ; 4/86: End of line LF XCHAR=LF RETURN ELSE XNEW=NO DGETCH=OK XCHAR=XLIN(1) XCOUNT=2 RETURN ENDIF ENDIF ELSE IF(XLIN(XCOUNT).EQ.LF.AND.XLIN(XCOUNT+1).EQ.EOS) THEN ; PM XNEW=YES DGETCH=LDELIM ; 4/86 End of Line LF XCHAR=LF RETURN ELSE DGETCH=OK XCHAR=XLIN(XCOUNT) XCOUNT=XCOUNT+1 RETURN ENDIF ENDIF RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION DGETLIN(FileMode,ALIN,CH) C C Read a record from the SENDing file and upack it into C the array ALIN. C C PM 3/85 C JL 5/10/84 11:25 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 PT,BUFFCHAN(20),RECLCHAN(20),MAXCHAN COMMON /IOUNIT/ PT,BUFFCHAN, RECLCHAN,MAXCHAN INTEGER*2 CH,ALIN(1) INTEGER*2 ACOUNT,BCOUNT,STATUS INTEGER*2 IOS,TV2 INTEGER TV1,ITEMP1,ITEMP2,RECLEN,RECLEN2 CHARACTER BLIN*264, CHARINP*2, SPACE*1/' '/,SPACES*264/' '/ INTEGER*2 INPCHAR,FileMode,BLIN2(132) INTEGER MLeft/Z0000FF00/, MRight/Z000000FF/ EQUIVALENCE (INPCHAR,CHARINP) C.............................................................. RECLEN=RECLCHAN(CH-1) ; RecLen of File to be Read DO 100 I=1,264 100 ALIN(I)=0 C Read a formatted record (TEXT mode) IF (FileMode.EQ.TXTFILE) THEN ; TEXT read BLIN=SPACES READ(UNIT=CH,IOSTAT=IOS,FMT='(A)')BLIN(1:RECLEN) IF(IOS.GT.0)THEN WRITE(20,*) ' DGETLIN Ascii Read Error - ',IOS GOTO 999 ; Handle error as EOF ELSE IF (IOS.LT.0) THEN IF (IOS.EQ.-2) THEN ; Trap EOF on '/*' read and BLIN(1:2) = '/*' ; process '/*' as data only ELSE GOTO 999 ; Any other EOF condition ENDIF ENDIF ENDIF DO 200 I=RECLEN,1,-1 ; Scan record backwards for blanks IF (BLIN(I:I).NE.SPACE) GOTO 210 200 CONTINUE 210 ACOUNT=I DO 220 I=1,ACOUNT INPCHAR=0 CHARINP(2:2)=BLIN(I:I) ALIN(I)=INPCHAR 220 CONTINUE ALIN(ACOUNT+1)=LF ALIN(ACOUNT+2)=EOS DGETLIN=OK RETURN ELSE C Read an Unformatted record (BINARY mode) RECLEN2=RECLEN/2 READ(CH,IOSTAT=IOS)(BLIN2(I),I=1,RECLEN2) IF(IOS.NE.0)THEN WRITE(20,*) ' DGETLIN Image Read Error - ',IOS GOTO 999 ; Handle error as EOF ENDIF ACOUNT = 0 DO 300 I=1,RECLEN2 ACOUNT = ACOUNT + 1 ITEMP1 = BLIN2(I) ALIN(ACOUNT) = IAND(ITEMP1,MLEFT) / 256 ACOUNT = ACOUNT + 1 ALIN(ACOUNT) = IAND(ITEMP1,MRIGHT) 300 CONTINUE ALIN(ACOUNT+1) = LF ALIN(ACOUNT+2) = EOS DGETLIN = OK RETURN ENDIF C Here for EOF on input file 999 CONTINUE DGETLIN=EOF RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE DPUTCH(XCHAR,CH) C C Output a char to the disk file channel C C PM 4/86 (SkipCR update: 5/8/86) C JL 4/25/84 14:25 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER XCHAR*2,CH*2,TV1*2,TV2*4, RecLen*4 INTEGER*2 PT,BUFFCHAN(20),RECLCHAN(20),MAXCHAN LOGICAL SkipCR ; 5/8/86 PM SAVE SkipCR ; Full rec CR skip flag COMMON /IOUNIT/ PT,BUFFCHAN, RECLCHAN,MAXCHAN COMMON /XBYTE/ XNEW,XCOUNT,XLIN(264),XEOF DATA SkipCR/.FALSE./ RecLen=RECLCHAN(CH-1) ; Get Record length of RECEIVE file IF (XCHAR.EQ.CR.AND.FMode.EQ.TXTFILE) THEN IF (SkipCR) THEN SkipCR = .FALSE. IF (XCOUNT.EQ.1) THEN ; Skip only if end of last rec CONTINUE ELSE XLIN(XCOUNT)=LF ; Handle end of Record XLIN(XCOUNT+1)=EOS CALL DPUTLIN(FMode,XLIN,CH,RecLen) ;Write rec to file XCOUNT=1 ENDIF ELSE XLIN(XCOUNT)=LF ; Write out Record XLIN(XCOUNT+1)=EOS CALL DPUTLIN(FMode,XLIN,CH,RecLen) ;Write rec to file XCOUNT=1 ENDIF ELSE XLIN(XCOUNT)=XCHAR ; CR may be part of BINARY record XCOUNT=XCOUNT+1 IF (XCOUNT.GT.RecLen) THEN ; check for "O/P Line IF (FMode.EQ.TXTFILE) SkipCR = .TRUE. XLIN(XCOUNT)=LF ; Write out Record XLIN(XCOUNT+1)=EOS CALL DPUTLIN(FMode,XLIN,CH,RecLen) ;Write rec to file XCOUNT=1 ENDIF ENDIF RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE DPUTLIN(FileMode,ALIN,CH,RecLen) C C Write ALIN to a disk file C C (Updated 6/9/86 - Look for LF/EOS as BIN file rec end C JL 5/11/84 10:00 ** PM 1/85 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 CH,IOS,ACOUNT,BLEN,INPCHAR,XCR,ALIN(1) CHARACTER BLIN*264,CHARINP*2,RLENCH*4,FORMT*10 INTEGER RecLen INTEGER*2 FileMode, BLIN2(132) EQUIVALENCE (INPCHAR,CHARINP) C ...........................................TEXT/Ascii output IF (FileMode.EQ.TXTFILE) THEN ; TEXT ACOUNT=1 100 IF (ALIN(ACOUNT).NE.LF) THEN INPCHAR=ALIN(ACOUNT) BLIN(ACOUNT:ACOUNT)=CHARINP(2:2) ACOUNT=ACOUNT+1 GOTO 100 ENDIF BLEN=ACOUNT-1 IF (BLEN.GT.RecLen) BLEN=RecLen C Write the Record to Receiving file RLENCH=ITOC(RecLen,K) FORMT= '(' // RLENCH(1:K) // 'A1)' IF (BLEN.LE.0) THEN ; Empty line, print only WRITE(CH,FMT=FORMT,IOSTAT=IOS) " " ; Empty Rec ELSE WRITE(CH,FMT=FORMT,IOSTAT=IOS)(BLIN(I:I),I=1,BLEN) ENDIF IF (IOS.NE.0) THEN WRITE(20,*) 'DPUTLIN - Ascii Write Error: ',IOS ENDIF GOTO 900 ELSE C ................................Binary/IMAGE file output ACOUNT=1 BLEN = 0 200 IF (ALIN(ACOUNT).NE.LF.OR.ALIN(ACOUNT+1).NE.EOS) THEN ;PM BLEN = BLEN + 1 BLIN2(BLEN) = ALIN(ACOUNT) * 256 ACOUNT = ACOUNT + 1 IF((ALIN(ACOUNT).NE.LF).OR.(ALIN(ACOUNT+1).NE.EOS)) THEN BLIN2(BLEN) = BLIN2(BLEN) + ALIN(ACOUNT) ACOUNT=ACOUNT+1 ENDIF GOTO 200 ; Assume Even number chars ENDIF IF ((BLEN*2).GT.RecLen) BLEN=RecLen/2 IF (BLEN.GT.0) THEN WRITE(CH,IOSTAT=IOS)(BLIN2(I),I=1,BLEN) IF (IOS.NE.0) THEN WRITE(20,*) 'DPUTLIN - Image Write Error: ',IOS IF (DEBUGON.EQ.YES) THEN ; Note file error WRITE(20,*) 'BLEN-',BLEN,' REC-',(BLIN2(I),I=1,BLEN) ENDIF ENDIF ENDIF ENDIF 900 RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION CHARTOI(IN, I) C Convert CHARACTER string to INTEGER eqiuivalent C----------------------------------------------------------------- $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 IN(1),I,S 23000 IF(.NOT.(IN(I).EQ.32.OR.IN(I).EQ.9))GOTO 23001 I = I + 1 GOTO 23000 23001 CONTINUE IF(.NOT.(IN(I).EQ.45.OR.IN(I).EQ.43))GOTO 23002 S = IN(I) I = I + 1 GOTO 23003 23002 CONTINUE S = 0 23003 CONTINUE CHARTOI = 0 23004 IF(.NOT.(IN(I).NE.10002))GOTO 23006 IF(.NOT.(IN(I).LT.48.OR.IN(I).GT.57))GOTO 23007 GOTO 23006 23007 CONTINUE CHARTOI = 10 * CHARTOI + IN(I) - 48 I = I + 1 GOTO 23004 23006 CONTINUE IF(.NOT.(S .EQ. 45))GOTO 23009 CHARTOI = -CHARTOI 23009 CONTINUE RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION CTL(T) C C Toggle the control bit of a character so that, for example, C Control-A becomes A, and vice-versa. C C JL 4/18/83 14:50 C----------------------------------------------------------------- INTEGER T*2, TT*4 TT=T CTL=IEOR(TT,64) ;Flip the 7th Bit RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION FINDLN(LIN,APAT,A1,Z1) C C This function will try to find the pattern within a line C It also returns pointers to the pattern's Begin/End characters. C 'A1' points to the character location where search is to C begin. The values returned in 'A1' and 'Z1' point to Begin/End C characters of 'Found' pattern. FINDLN=YES if pattern found, C while FINDLIN=NO if pattern not found. (EOS is not included C in A1 -> Z1 pattern pointers.) C C LIN holds the line to search; APAT holds pattern to search for. C C JL 4/18/84 14:50 C----------------------------------------------------------------- INTEGER*2 LIN(1),APAT(1),A1,Z1,STATUS,T1,T2,T3,FLAG INTEGER NChars,NSigC PARAMETER (NSigC=3) ; Number Significant chars requ'd $INCLUDE KERDEF (NLIST) $NLIST NChars=0 STATUS=OK T1=A1 C Search until First char. of pattern matches a char. in line; exit C when EOS is found. 100 IF (STATUS.EQ.OK)THEN ;do forever, Break within loop 110 IF ((LIN(T1).NE.APAT(1)).AND.(LIN(T1).NE.EOS)) THEN T1=T1+1 GOTO 110 ENDIF IF(LIN(T1).EQ.EOS)THEN ;we hit EOS on the line, no match STATUS=NO ELSE A1=T1 T2=1 T3=T1 FLAG=NO 120 IF ((FLAG.EQ.NO).AND.(APAT(T2).NE.EOS)) THEN IF(APAT(T2).EQ.LIN(T1))THEN T1=T1+1 T2=T2+1 NChars = NChars + 1 ELSE FLAG=YES ;we got partial matching , no exact ENDIF GOTO 120 ENDIF IF(APAT(T2).EQ.EOS.OR.NChars.GE.NSigC)THEN Z1=T1-1 STATUS=YES ELSE T1=T3+1 ENDIF ENDIF NChars=0 ; Restart Sig Chars count GOTO 100 ; Loop until EXIT ENDIF FINDLN=STATUS RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION FLIP8BIT(T) C C Toggle 8th bit of byte in low end of 'XCHAR' C C PM 1/15/85 12:00 C----------------------------------------------------------------- INTEGER T*2, TT*4 TT=T FLIP8BIT=IEOR(TT,128) ; Flip the 8th bit RETURN END $NLIST C--------------------------------------------------------------------- SUBROUTINE FLUSHBUF(CH) C C -- Write remaining bytes in XLIN out to receiving file after EOF C packet received in RDATA C PM 4/22/86 C--------------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 CH, BUFFCHAN(20), RECLCHAN(20), MAXCHAN, XFILL INTEGER*4 RecLen,I COMMON /IOUNIT/ PT,BUFFCHAN,RECLCHAN,MAXCHAN COMMON /XBYTE/ XNEW, XCOUNT, XLIN(264), XEOF IF (XCOUNT.GT.1) THEN ;Fill only if Buffer not empty RecLen=RECLCHAN(CH-1) IF (FMode.EQ.TXTFILE) THEN XFILL=BLANK ; Spaces for ASCII file ELSE XFILL=0 ; Zeros for BINARY/CONTIG Fill ENDIF DO 100 I=XCOUNT,RecLen 100 XLIN(I) = XFILL XCOUNT=I XLIN(XCOUNT)=LF XLIN(XCOUNT+1)=EOS CALL DPUTLIN(FMode,XLIN,CH,RecLen) XCOUNT=1 ENDIF RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION GETCHAN(CHAN) C C JL 4/25/84 13:35 C----------------------------------------------------------------- IMPLICIT INTEGER*2 (A-Z) COMMON /IOUNIT/ PT,BUFFCHAN(20), RECLCHAN(20),MAXCHAN $INCLUDE KERDEF (NLIST) $NLIST IF(PT.GT.MAXCHAN)THEN GETCHAN=BAD ;already used-up all available channels ELSE GETCHAN=BUFFCHAN(PT) ;there are more available channels PT=PT+1 ENDIF RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION IBMGETLIN(BUFFER,CH) C C Read a packet with a SOH in it and wait for the prompt C before returning it C C BUFFER is an integer array that will hold the incoming packet C CH tells this routine which channel to read the packet from C (Used for interaction with IBM half-duplex lines) C C JL 4/18/84 15:00 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 BUFFER(132),CH,STATUS,GASOH,COUNT,T,IBYTE INTEGER*2 TGETCH,X STATUS=YES GASOH=NO ;we have not gotten a packet yet COUNT=1 100 IF (STATUS.EQ.YES) THEN 110 IF (GASOH.EQ.NO) THEN ;keep reading one byte at a tim IBYTE=0 ;the I/O port until you see the X=TGETCH(IBYTE,CH) ;character , EOF is not expected IF(IBYTE.EQ.SOH)THEN GASOH=YES ;I got the SOH BUFFER(COUNT)=IBYTE ;store the SOH into buffer COUNT=COUNT+1 ;increment the buffer pointer ENDIF GOTO 110 ENDIF IBYTE=0 X=TGETCH(IBYTE,CH) ;read a byte from the I/O port IF(IBYTE.EQ.PROMPT)THEN ; we got the prompt STATUS=NO ELSE BUFFER(COUNT)=IBYTE ;it is not a prompt, but another COUNT=COUNT+1 ;data of the incoming packet ENDIF ;store it and increment pointer GOTO 100 ENDIF BUFFER(COUNT)=EOS ;add an EOS into end of buffer IBMGETLIN=OK RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION KGETLIN(BUFFER,CH) C C read a packet with a SOH in it and DON'T wait for the prompt C before returning it C C BUFFER is an integer array that will hold the incoming packet C CH tells this routine which channel to read the packet from C C JL 4/18/84 15:00 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 BUFFER(132),CH,STATUS,GASOH,COUNT,T,IBYTE INTEGER*2 TGETCH,X C STATUS=YES GASOH=NO ;we have not gotten a packet yet COUNT=1 100 IF (STATUS.EQ.YES) THEN 110 IF (GASOH.EQ.NO) THEN ;keep reading one byte at a tim IBYTE=0 ;the I/O port until you see the X=TGETCH(IBYTE,CH) ;character , EOF is not expected IF(IBYTE.EQ.SOH)THEN GASOH=YES ;I got the SOH BUFFER(COUNT)=IBYTE ;store the SOH into buffer COUNT=COUNT+1 ;increment the buffer pointer ENDIF GOTO 110 ENDIF IBYTE=0 X=TGETCH(IBYTE,CH) ;read a byte from the I/O port IF(IBYTE.EQ.MYEOL)THEN ;we got the required MYEOL STATUS=NO ELSE BUFFER(COUNT)=IBYTE ;it is not MYEOL, but another COUNT=COUNT+1 ;data of the incoming packet ENDIF ;store it and increment pointer GOTO 100 ENDIF BUFFER(COUNT)=EOS ;add an EOS into end of buffer KGETLIN=OK RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE PACK(XFROM,XTO) C C Pack the Filename from XFROM into character array XTO C C JL 5/2/84 10:38 C----------------------------------------------------------------- INTEGER*2 XFROM(1),MAXLEN CHARACTER XTO*12, SPACES*12/' '/,TVCHAR*2 INTEGER*2 FCOUNT,TCOUNT,TV EQUIVALENCE(TV,TVCHAR) $INCLUDE KERDEF (NLIST) $NLIST FCOUNT=1 ;start with the first word of the XFROM array MAXLEN=12 ; Maximum file name length TCOUNT=1 ;start with the first word of the XTO array XTO=SPACES C 100 IF (XFROM(FCOUNT).NE.EOS)THEN ;Do until EOS is detected TV=XFROM(FCOUNT) XTO(TCOUNT:TCOUNT)=TVCHAR(2:2) TCOUNT=TCOUNT+1 FCOUNT=FCOUNT+1 IF(TCOUNT.GT.MAXLEN) GOTO 900 GOTO 100 ENDIF 900 RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE PARSER C C The main parser at the command level: Search for C for Kermit commands & route to appropriate routine. C -- If LU 16 has been opened in .CSS, read initial settings C from it, else check for 'KERMIT.INI'. C C PM 4/86 C JL 4/18/84 17:00 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 ICONNECT(8),IEXIT(5),IHELP(5),IQUIT(5) INTEGER*2 IRECEIVE(8),ISET(4),ISEND(5),ISTATUS(7),ISERVER(7) INTEGER*2 ALIN(132),BLIN(132),TV,STATUS,A1,Z1,INITIAL INTEGER*2 GETKEYBD,FINDLN,LFCR,XREAD,XWRITE,IniCH,X,CHARTOI INTEGER*2 IniFile(132), FLAG1 INTEGER LUN, NRECS, IniLU LOGICAL TOBE, IniOPEN CHARACTER*12 CPROMPT C DATA XREAD/0/, XWRITE/1/, IniLU/16/ DATA LFCR/Z0A0D/, CPROMPT/'Kermit-CO> '/ DATA ICONNECT /67,79,78,78,69,67,84,10002/ DATA IEXIT /69,88,73,84,10002/ DATA IHELP /72,69,76,80,10002/ DATA IQUIT /81,85,73,84,10002/ DATA IRECEIVE /82,69,67,69,73,86,69,10002/ DATA ISET /83,69,84,10002/ DATA ISEND /83,69,78,68,10002/ DATA ISTATUS /83,84,65,84,85,83,10002/ DATA ISERVER /83,69,82,86,69,82,10002/ C.......................PARSER until EXIT/QUIT................. IniFile(1)=BIGK IniFile(2)=BIGE IniFile(3)=BIGR IniFile(4)=BIGM IniFile(5)=BIGI IniFile(6)=BIGT IniFile(7)=PERIOD IniFile(8)=BIGI IniFile(9)=BIGN IniFile(10)=BIGI IniFile(11)=LF IniFile(12)=EOS STATUS=YES INITIAL=NO C If LU 16 is opened in CSS, process commands from it LUN=IniLU INQUIRE(UNIT=LUN,OPENED=IniOPEN,SIZE=NRECS) ;Ini file in CSS? LUN=LOCALOUTFD IF (IniOPEN) THEN IniCH = IniLU INITIAL=YES ; Enable Startup initialization WRITE(LUN,1210) ; Flash User msg ELSE INQUIRE(FILE='KERMIT.INI',EXIST=TOBE) ;Check default .INI IF (TOBE) THEN IniCH=AOPEN(TXTFILE,IniFile,XREAD) IF (IniCH.EQ.BAD) THEN WRITE(20,*) 'PARSER - Cant open KERMIT.INI' INITIAL=NO ELSE INITIAL=YES ; Enable Startup initialization WRITE(LUN,1200) ; Flash User msg ENDIF ENDIF ENDIF C ...............................Process KERMIT commands 100 IF (STATUS.EQ.YES) THEN IF (INITIAL.EQ.YES) THEN ; Commands from .INI file TV=DGETLIN(TXTFILE,ALIN,IniCH) IF (TV.EQ.EOF) THEN IF (IniCH.EQ.IniLU) THEN CLOSE(IniLU) ; CSS open file ELSE CALL RATCLOSE(IniCH) ;Close Internal file channel ENDIF INITIAL=NO ; End Initialization CALL PUTSTRNG(LOCALOUTFD,2,LFCR) GOTO 100 ; Start in on console now ENDIF CALL PUTSTRNG(LOCALOUTFD,2,LFCR) ;Send LF,CR to Display CALL PUTLIN(ALIN,LOCALOUTFD) ; Show command line ELSE CALL PUTSTRNG(LOCALOUTFD,2,LFCR) ;Send LF,CR to Display CALL PUTSTRNG(LOCALOUTFD,10,CPROMPT) ;Prompt TV=GETKEYBD(ALIN,LOCALINFD) ;read line from local keyboard ENDIF IF (ALIN(1).EQ.LF) GOTO 100 ; Nothing input, repeat prompt CALL UPPER(ALIN,BLIN) ;converts it to uppercase A1=1 FLAG1=FINDLN(BLIN,ISEND,A1,Z1) ; SEND IF (FLAG1.EQ.YES) THEN CALL SSEND(BLIN) GOTO 100 ENDIF A1=1 FLAG1=FINDLN(BLIN,ISET,A1,Z1) ; SET IF (FLAG1.EQ.YES) THEN CALL SSET(BLIN) GOTO 100 ENDIF A1=1 FLAG1=FINDLN(BLIN,IEXIT,A1,Z1) ; EXIT IF (FLAG1.EQ.YES) THEN RETURN ; Back to Mainline ENDIF A1=1 FLAG1=FINDLN(BLIN,IHELP,A1,Z1) ; HELP IF (FLAG1.EQ.YES) THEN CALL SHELP GOTO 100 ENDIF A1=1 FLAG1=FINDLN(BLIN,IQUIT,A1,Z1) ; QUIT IF (FLAG1.EQ.YES) THEN RETURN ;Back to Mainline ENDIF A1=1 FLAG1=FINDLN(BLIN,ISTATUS,A1,Z1) ; STATUS IF (FLAG1.EQ.YES) THEN CALL SSTATUS GOTO 100 ENDIF A1=1 FLAG1=FINDLN(BLIN,ISERVER,A1,Z1) ; SERVER IF (FLAG1.EQ.YES) THEN CALL SSERVER GOTO 100 ENDIF A1=1 FLAG1=FINDLN(BLIN,IRECEIVE,A1,Z1) ; RECEIVE IF (FLAG1.EQ.YES) THEN X=0 A1=Z1+1 CALL SKIPBL(BLIN,A1) X=CHARTOI(BLIN,A1) ; Get Rec len if on command line CALL SRECEIVE(X) GOTO 100 ENDIF A1=1 FLAG1=FINDLN(BLIN,ICONNECT,A1,Z1) ; CONNECT IF (FLAG1.EQ.YES) THEN CALL SCONNECT GOTO 100 ENDIF WRITE(LUN,1000) ; Command not recognized GOTO 100 ENDIF RETURN 1000 FORMAT(/' Unrecognized command (Type HELP for ideas)') 1200 FORMAT(/' Initializing from KERMIT.INI...') 1210 FORMAT(/' Initializing from User file...') END $NLIST C----------------------------------------------------------------- SUBROUTINE PUTCHAN(CHAN) C C JL 4/25/84 13:35 C----------------------------------------------------------------- IMPLICIT INTEGER*2 (A-Z) COMMON /IOUNIT/ PT,BUFFCHAN(20), RECLCHAN(20),MAXCHAN $INCLUDE KERDEF (NLIST) $NLIST IF(PT.LE.1)RETURN ;no channel was allocated at all PT=PT-1 BUFFCHAN(PT)=CHAN RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE RATCLOSE(CH) C C Close that channel and return it to the channel pool C C JL 4/25/84 13:50 C----------------------------------------------------------------- INTEGER*2 CH,IOS IF (CH.GT.0) THEN CALL PUTCHAN(CH) CLOSE(CH) ENDIF RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION RDATA(X) C C Read a data packet from the other KERMIT C C JL 4/18/84 15:05 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 NUM,LEN,STATUS,X,RPACK,TNUM INTEGER*2 TV1,TV2,TV3,TV4,NMinus INTEGER ITEMP,LUN C IF(NUMTRY.GT.MAXTRY)THEN WRITE(20,*) 'RDATA - MAXTRY exceeded ' RDATA=BIGA ;exceeded maxtry , gives up CALL RATCLOSE(FD) RETURN ELSE NUMTRY=NUMTRY+1 ;try it again ENDIF STATUS=RPACK(LEN,NUM,PACKET) ;read a packet C Get (N-1) modulo'd properly for comparison with NUM (D.MacPhee) IF (N.EQ.0) THEN NMinus = 63 ELSE NMinus = N - 1 ENDIF IF(HOSTON.EQ.NO)THEN ;if we are running in remote LUN=LOCALOUTFD WRITE(LUN,100)NUM ;mode the diepay packet # ENDIF IF(STATUS.EQ.BIGD)THEN ;we got the data packet IF(NUM.NE.N)THEN IF(OLDTRY.GT.MAXTRY)THEN RDATA=BIGA CALL RATCLOSE(FD) WRITE(20,*) ' RDATA - MAXTRY exceeded - 2nd test' RETURN ELSE OLDTRY=OLDTRY+1 ENDIF IF(NUM.EQ.NMinus)THEN ; We got a duplicated packet TV1=BIGY ;just ACK it TV2=0 TV3=0 CALL SPACK(TV1,NUM,TV2,TV3) NUMTRY=0 RDATA=STATE RETURN ELSE RDATA=BIGA WRITE(20,*) ' RDATA - NUM ne (N-1) - State = ',STATE CALL RATCLOSE(FD) RETURN ENDIF ENDIF CALL BUFEMP(PACKET,LEN) ;write the data packet just receive TNUM=N ;into the receiving disk file TV1=BIGY TV2=TNUM TV3=0 TV4=0 CALL SPACK(TV1,TV2,TV3,TV4) ;ACK the just received packet OLDTRY=NUMTRY NUMTRY=0 ITEMP=N+1 N=MOD(ITEMP,64) RDATA=BIGD RETURN ELSE IF(STATUS.EQ.BIGF)THEN ;the packet is the file header IF(OLDTRY.GT.MAXTRY)THEN ;we should have already got RDATA=BIGA ;exceeded number of retry, give up CALL RATCLOSE(FD) WRITE(20,*) ' RDATA - MAXTRY exceeded - Status = F' RETURN ELSE OLDTRY=OLDTRY+1 ENDIF IF(NUM.EQ.NMinus)THEN ;we got duplicate file header TV1=BIGY TV2=0 TV3=0 CALL SPACK(TV1,NUM,TV2,TV3) ;just ACK it NUMTRY=0 RDATA=STATE RETURN ELSE RDATA=BIGA WRITE(20,*) ' RDATA - NUM .NE. (N-1) - Status = F' CALL RATCLOSE(FD) RETURN ENDIF ELSE IF(STATUS.EQ.BIGZ)THEN ;we got the EOF packet IF(NUM.NE.N)THEN WRITE(20,*) ' RDATA - NUM .NE. N - Status = Z' RDATA=BIGA CALL RATCLOSE(FD) RETURN ENDIF TNUM=N TV1=BIGY TV2=0 TV3=0 CALL SPACK(TV1,TNUM,TV2,TV3) ;ACK it CALL FLUSHBUF(FD) ;Flush XLIN buffer CALL RATCLOSE(FD) ;close the receiving disk fi ITEMP=N+1 N=MOD(ITEMP,64) RDATA=BIGF ;change the state to look fo RETURN ;another file header ELSE IF(STATUS.EQ.BAD)THEN WRITE(20,*) ' RDATA - Status BAD - CHKSUM error?' RDATA=STATE ;there was an error in the TNUM=N ;checksum TV1=BIGN TV2=0 TV3=0 CALL SPACK(TV1,TNUM,TV2,TV3) ;NAK it RETURN ELSE RDATA=BIGA ;we got a unknown packet type WRITE(20,*) ' RDATA - UNKNOWN PACKET - Status = A' CALL RATCLOSE(FD) ENDIF ;gives up RETURN 100 FORMAT(' ','Packet # ',I4) END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION RECSW(X) C C Receive a file or a group of files from the other KERMIT C C JL 4/18/84 17:06 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST COMMON /XBYTE/ XNEW,XCOUNT,XLIN(264),XEOF INTEGER*2 X,RDATA,RFILE,RINIT,STATUS INTEGER*2 TV1,TV2,TV3,TV4 STATUS=YES STATE=BIGR XNEW=YES XCOUNT=1 N=0 NUMTRY=0 100 IF (STATUS.EQ.YES) THEN IF(STATE.EQ.BIGD)THEN ;read a DATA packet STATE=RDATA(X) ELSE IF(STATE.EQ.BIGR)THEN ;read a SINIT packet STATE=RINIT(X) ELSE IF(STATE.EQ.BIGF)THEN ;read a file header STATE=RFILE(X) ELSE IF(STATE.EQ.BIGC)THEN ;file transfer compl RECSW=YES RETURN ELSE IF(STATE.EQ.BIGA)THEN ;we got an error RECSW=NO TV1=BIGE TV2=N TV3=0 TV4=0 CALL SPACK(TV1,TV2,TV3,TV4) ;send ERROR packet RETURN ;file channel ENDIF GOTO 100 ENDIF RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE REMOVE(FNAME) C C JL 4/25/84 13:43 C----------------------------------------------------------------- INTEGER*2 FNAME(1),TFILE(13),IERR INTEGER*2 COUNT,MAXLEN,XLENGTH CHARACTER INAME*12 $INCLUDE KERDEF (NLIST) $NLIST MAXLEN=12 ;CCC OS/32 uses a max. filename length of 12 COUNT=1 C 100 IF ((FNAME(COUNT).NE.LF).AND. ;determine length of filenam + (FNAME(COUNT).NE.EOS)) THEN TFILE(COUNT)=FNAME(COUNT) COUNT=COUNT+1 GOTO 100 ENDIF C IF(COUNT.LE.MAXLEN)THEN ;fill up rest with trailing 200 IF (COUNT.LE.MAXLEN) THEN TFILE(COUNT)=BLANK COUNT=COUNT+1 GOTO 200 ENDIF ENDIF C ;pack the filename string TFILE(MAXLEN+1)=EOS CALL PACK(TFILE,INAME) OPEN(40,FILE=INAME,STATUS='OLD',ERR=111) CLOSE(40,STATUS='DELETE') RETURN 111 CONTINUE RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION RFILE(X) C C Read a file header packet from the other KERMIT C C JL 4/18/84 17:08 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 NUM,LEN,STATUS,RPACK,X,TNUM,AOPEN INTEGER*2 TV1,TV2,TV3,TV4,XWRITE,NMinus INTEGER ITEMP,LUN CHARACTER*12 FileName XWRITE=1 IF(NUMTRY.GT.MAXTRY)THEN WRITE(20,*) ' RFILE - MAXTRY exceeded - BIGA ' RFILE=BIGA ;exceeded max. # of re-try RETURN ;gives up ELSE NUMTRY=NUMTRY+1 ENDIF STATUS=RPACK(LEN,NUM,PACKET) C Calc N-1, properly Modulo'd, for compare with NUM (D.MacPhee) IF (N.EQ.0) THEN NMinus = 63 ELSE NMinus = N - 1 ENDIF IF(STATUS.EQ.BIGS)THEN ;we got a SINIT packet IF(OLDTRY.GT.MAXTRY)THEN WRITE(20,*) 'RFILE - MAXTRY exceeded (1) - Status = A' RFILE=BIGA ;re-try it again RETURN ELSE OLDTRY=OLDTRY+1 ENDIF IF(NUM.EQ.NMinus)THEN ;we already got the SINIT CALL SPAR(PACKET) ;packet, get my file-transfer TV1=BIGY ;requirement/parameters TV2=9 CALL SPACK(TV1,NUM,TV2,PACKET) ;ACK it NUMTRY=0 RFILE=STATE RETURN ELSE WRITE(20,*) ' RFILE - Unexpected Seq No 1 - Status=A' RFILE=BIGA ;unexpected sequence # RETURN ;gives up ENDIF ELSE IF(STATUS.EQ.BIGZ)THEN ;we got a EOF packet IF(OLDTRY.GT.MAXTRY)THEN RFILE=BIGA ;exceeded max # of re-try WRITE(20,*) ' RFILE - MAXTRY exceeded (2) - Status=A' RETURN ;gives up ELSE OLDTRY=OLDTRY+1 ;re-try one more time ENDIF IF(NUM.EQ.NMinus)THEN TV1=BIGY ;we already got the EOF pac TV2=0 TV3=0 CALL SPACK(TV1,NUM,TV2,TV3) ;just ACK it NUMTRY=0 RFILE=STATE RETURN ELSE RFILE=BIGA ;unexpected sequence # WRITE(20,*) ' RFILE - Unexpected Seq No (2) - A' RETURN ENDIF ELSE IF(STATUS.EQ.BIGF)THEN ;got file header packet IF(NUM.NE.N)THEN RFILE=BIGA ;unexpected sequence #,give WRITE(20,*) ' RFILE - Unexpected Seq No (3) - A' RETURN ENDIF PACKET(LEN+1)=LF ;packet(len) has the incomi PACKET(LEN+2)=EOS ;filename packet CALL VERIFY(PACKET) ;verify incoming filename IF(HOSTON.EQ.NO)THEN LUN=LOCALOUTFD CALL PACK(PACKET,FileName) WRITE(LUN,*) 'Receiving file--> ',FileName ENDIF FD=AOPEN(FMode,PACKET,XWRITE) ;open file for writing IF(FD.EQ.BAD)THEN RFILE=BIGA ;we got a ERR in opening th WRITE(20,*) ' RFILE - BAD File OPEN - Status = A' RETURN ENDIF TNUM=N TV1=BIGY TV2=0 TV3=0 CALL SPACK(TV1,TNUM,TV2,TV3) ;ACK the file header packet OLDTRY=NUMTRY NUMTRY=0 ITEMP=N+1 N=MOD(ITEMP,64) RFILE=BIGD ;change state to look for DA RETURN ;packet ELSE IF(STATUS.EQ.BIGB)THEN ;we got a BREAK transmission IF(NUM.NE.N)THEN RFILE=BIGA WRITE(20,*) ' RFILE - NUM.NE.N - Status = A/B' RETURN ENDIF TNUM=N TV1=BIGY TV2=0 TV3=0 CALL SPACK(TV1,TNUM,TV2,TV3) ;ACK the BREAK packet RFILE=BIGC ;change state to complete sta RETURN ELSE IF(STATUS.EQ.BAD)THEN ;we got an error on the check RFILE=STATE TNUM=N TV1=BIGN TV2=0 TV3=0 CALL SPACK(TV1,TNUM,TV2,TV3) ;NAK it RETURN ELSE RFILE=BIGA ;unexpected packet type, give up WRITE(20,*) 'RFILE - UNKNOWN PACKET - Status = A' ENDIF RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION RINIT(X) C C Receive the initial packet from the remote KERIT C C JL 4/18/84 17:10 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 LEN,NUM,STATUS,RPACK,X,TNUM INTEGER*2 TV1,TV2,TV3,TV4 INTEGER ITEMP IF(NUMTRY.GT.MAXTRY)THEN RINIT=BIGA ;exceeded max. # of re-try WRITE(20,*) ' RINIT - MAXTRY exceeded - Status = A' RETURN ;gives up ELSE NUMTRY=NUMTRY+1 ;try-it again ENDIF DO 100 I=1,40 PACKET(I)=0 100 CONTINUE STATUS=RPACK(LEN,NUM,PACKET) ;read a packet IF(STATUS.EQ.BIGS)THEN ;we got a SINIT packet CALL RPAR(PACKET) ;store other KERMIT's requirements CALL SPAR(PACKET) ;get our parameters/requir TNUM=N TV1=BIGY TV2=9 CALL SPACK(TV1,TNUM,TV2,PACKET) ;send out requirement and OLDTRY=NUMTRY ;ACK it on one shot NUMTRY=0 ITEMP=N+1 N=MOD(ITEMP,64) RINIT=BIGF ;change state to look for RETURN ;the file header packet ELSE IF(STATUS.EQ.BAD)THEN ;we got a checksum error RINIT=STATE TNUM=N TV1=BIGN TV2=0 TV3=0 CALL SPACK(TV1,TNUM,TV2,TV3) ;NAK it RETURN ELSE RINIT=BIGA ;we got an unexpected pack WRITE(20,*) ' RINIT - Unexpected Packet type - Status = A' ENDIF ;type, gives up RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION RPACK(LEN,NUM,XDATA) C C Read a packet from other KERMIT C C JL 4/18/84 17:10 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST *$TEST INTEGER*2 LEN,NUM,CH INTEGER*2 GETLIN,IBMGETLIN,T INTEGER*2 XDATA(132) INTEGER*2 I,COUNT,STATUS,UNCHAR,J,K,XCOUNT INTEGER*2 TV2,TV3,CHKSUM2 INTEGER TV1, ITEMP, CHKSUM INTEGER*2 BUFFER(132),XTYPE,GAPTRY,MGAPTRY CH=RMTINFD ;this is the input channel to GAPTRY=1 MGAPTRY=1 ; (Number of s need for to get re-transmit CHKSUM=0 C C Read a packet that begins with a SOH and ends with MYEOL 100 IF (GAPTRY.LE.MGAPTRY) THEN IF(IBMON.EQ.YES)THEN STATUS=IBMGETLIN(BUFFER,CH) ;get a packet and waits for t ELSE ;prompt STATUS=GETLIN(BUFFER,CH) ;get a packet without waitin ENDIF ;for a prompt C........................................UPDATE 9/15/85 C ********(TEST WITH THIS CODE HUNG THE PROGRAM C***********(CHECK USED OF EOF IN OTHER PARTS) 10/25/85 C Check for bad packet and reject if so IF (STATUS.EQ.EOF) THEN RPACK=BAD ; Reject on bad GETLIN RETURN ENDIF C........................................END UPDATE 9/15/85 COUNT=1 C skips all other characters until we see one with a SOH in it C 200 IF ((BUFFER(COUNT).NE.SOH).AND.(BUFFER(COUNT).NE.EOS)) THEN COUNT=COUNT+1 ;wait for a SOH or EOS GOTO 200 ENDIF IF(BUFFER(COUNT).EQ.SOH)THEN ;Got the SOH K=COUNT+1 CHKSUM=BUFFER(K) LEN=UNCHAR(BUFFER(K))-3 ;get the length of the packet K=K+1 CHKSUM=CHKSUM+BUFFER(K) NUM=UNCHAR(BUFFER(K)) ;Get Frame Packet Seq Number K=K+1 XTYPE=BUFFER(K) ;get the data type CHKSUM=CHKSUM+BUFFER(K) K=K+1 C C Zero out XDATA array; Get the data DO 300 I=1,132 300 XDATA(I)=0 DO 400 J=1,LEN XDATA(J)=BUFFER(K) CHKSUM=CHKSUM+BUFFER(K) K=K+1 COUNT=J 400 CONTINUE XDATA(COUNT+1)=EOS T=BUFFER(K) C C Calculate the checksum of Incoming Packet. TV1=IAND(CHKSUM,192) ITEMP=CHKSUM+(TV1/64) CHKSUM2=IAND(ITEMP,63) C C Does the checksum match? IF(CHKSUM2.NE.UNCHAR(T))THEN IF (DEBUGON.EQ.YES) THEN WRITE(20,*) ' RPACK- CALC CHKSM - ',CHKSUM2 WRITE(20,*) ' RCVD CHKSUM- ',T,' REC NO - ',NUM ENDIF RPACK=BAD ;bad checksum RETURN ELSE RPACK=XTYPE RETURN ENDIF ENDIF C We got the EOS, the packet has no SOH, read another one GAPTRY=GAPTRY+1 IF(DEBUGON.EQ.YES)WRITE(20,*) 'RPACK - No SOH GAP ',GAPTRY GOTO 100 ; Loop Till EOS ENDIF RPACK=BAD RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE RPAR(XDATA) C C Store the other KERMIT's file transfer requirement away C C JL 4/18/84 17:13 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 XDATA(1),UNCHAR,CTL,ITEMP I=1 ; Use Relative index IF(XDATA(I).EQ.0)THEN ; IF no packet size sent by other SPSIZ=PAKSIZ ; KERMIT, use local KERMIT default ELSE SPSIZ=UNCHAR(XDATA(I)) ENDIF SPSIZADJ = SPSIZ-6 ;Size adjusted for Seq,Siz,Type (BUFFILL) IF(XDATA(I+1).NE.0)TIMEOUT=UNCHAR(XDATA(I+1)) IF(XDATA(I+2).NE.0)PAD=UNCHAR(XDATA(I+2)) IF(XDATA(I+3).NE.0)PADCHAR=CTL(XDATA(I+3)) IF(XDATA(I+4).NE.0)EOL=UNCHAR(XDATA(I+4)) IF(XDATA(I+5).NE.0)QUOTE=XDATA(I+5) C C Establish whether remote Kermit will do 8-Bit prefixing ITEMP=XDATA(I+6) QUOT8B=NO ; Assume it won't IF (MYQUOT8B.EQ.NO) GOTO 999 ;If not set, No 8-Bit quoting IF (ITEMP.EQ.BIGN) GOTO 999 ; Remote refuses to 8-Bit prefix IF (ITEMP.EQ.BIGY) THEN QUOT8B=YES ; Remote will do 8-bit quoting GOTO 999 ENDIF IF (((BANG.LE.ITEMP).AND.(ITEMP.LT.QMARK)) .OR. ; 33-62? & ((ITEMP.GT.LETA).AND.(TILDE.GE.ITEMP))) THEN ; 96-126? Q8BCHR=ITEMP ; Use this as 8 Bit Quote QUOT8B=YES ENDIF 999 RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION SBREAK(X) C C Send the break packet to signify the end of transmissions C C JL 4/18/84 17:15 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 NUM,LEN,RPACK,STATUS,X,TNUM INTEGER*2 TV1,TV2,TV3 INTEGER ITEMP IF(NUMTRY.GT.MAXTRY)THEN SBREAK=BIGA ; exceeded max. no. Retries WRITE(20,*) ' SBREAK - MAXTRY exceeded - Status = A' RETURN ;gives up ELSE NUMTRY=NUMTRY+1 ;try it again ENDIF C TNUM=N TV1=BIGB TV2=0 TV3=0 CALL SPACK(TV1,TNUM,TV2,TV3) STATUS=RPACK(LEN,NUM,RECPKT) SBREAK=STATE ; Default to STATE C IF(STATUS.EQ.BIGN)THEN ;we got a NAK packet IF(N.NE.(NUM-1))THEN SBREAK=STATE RETURN ENDIF ELSE IF(STATUS.EQ.BIGY)THEN ;we got a ACK packet IF(N.NE.NUM)THEN SBREAK=STATE ;but it is out of seque RETURN ENDIF NUMTRY=0 ITEMP=N+1 N=MOD(ITEMP,64) SBREAK=BIGC ;change state to comple RETURN ;status ELSE IF(STATUS.EQ.BAD)THEN SBREAK=STATE RETURN ELSE WRITE(20,*) ' SBREAK - Unknown Packet - Status = A' SBREAK=BIGA ;receive unknown packet ENDIF ;type or error packet RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE SCONNECT C C Put this terminal into CHAT mode C C (This routine would be used by the P-E in LOCAL mode, C which is currently unimplemented.) C (look for it in Version 3.0) C C JL 4/27/84 11:30 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 IBUF,ILEN,TV,IWRITE,IESCHAR,STATUS,IA,IB INTEGER*2 IFUNC,ICLAS,LUTERM,TLEN,RMTRAW,LOCALRAW INTEGER*2 TCODE INTEGER LUN C LUN=LOCALOUTFD WRITE(LUN,1000) C STATUS=YES C IESCHAR=ISHFT(ESCHAR,8) C TCODE=17 C CALL SETRAW(RMTINFD,RMTTTY) C CALL SETPAR(RMTINFD,RMTTTY) C CALL SETBAUD(RMTINFD,RMTTTY) C CALL SETPORT(RMTINFD,RMTTTY) C C WRITE(LUN,101) C WRITE(LUN,102)ESCHAR C C ILEN=-1 C TLEN=-1 C IWRITE=2 C RMTRAW=RMTOUTFD+2000B C LOCALRAW=LOCALOUTFD+2000B C CALL EXEC(TCODE,LOCALINFD,IBUF,ILEN,LOCALINFD,0,ICLAS) C CALL EXEC(TCODE,RMTINFD,IBUF,ILEN,RMTINFD,0,ICLAS) C ICLAS=IOR(ICLAS,20000B) C C IF (STATUS.EQ.YES) C CALL EXEC(21,ICLAS,IBUF,TLEN,LUTERM) C WRITE(LUN,333)LUTERM C 333 FORMAT(' ','VALUE OF LUTERM IS ',I5) C WRITE(LUN,334)IBUF C 334 FORMAT(' ','VALUE OF IBUF READ IS ',I5) C IF(LUTERM.EQ.LOCALINFD)THEN C TV=IAND(IBUF,77400B) C IF(TV.EQ.IESCHAR)THEN C WRITE(LUN,103) C CALL SETCOOK(RMTINFD,RMTTTY) C RETURN C ENDIF C IF(IBMON.EQ.YES)THEN C CALL EXEC(IWRITE,LOCALRAW,IBUF,-1,*100) C ENDIF C CALL EXEC(IWRITE,RMTRAW,IBUF,-1,*100) C CALL EXEC(TCODE,LOCALINFD,IBUF,ILEN,LOCALINFD,0,ICLAS) C ELSE C CALL EXEC(IWRITE,LOCALRAW,IBUF,-1,*100) C CALL EXEC(TCODE,RMTINFD,IBUF,ILEN,RMTINFD,0,ICLAS) C ENDIF C ENDIF C C 100 CONTINUE C CALL ABREG(IA,IB) C WRITE(LUN,104) C WRITE(LUN,105)IA,IB RETURN 1000 FORMAT(/' CONNECT is unavailable under Kermit-CO 2.1') C 101 FORMAT(' ','To exit from CHAT mode; type the') C 102 FORMAT(' ','equalivent control character of ',I4) C 103 FORMAT(' ','Returning to Kermit-CO') C 104 FORMAT(' ','Error in performing EXEC write in SCONNECT') C 105 FORMAT(' ','Value of IA & IB are ',A2,' = ',A2) END $NLIST C----------------------------------------------------------------- SUBROUTINE SCOPY(XFROM,I,XTO,J) C----------------------------------------------------------------- INTEGER*2 XFROM(1),XTO(1),I,J,K1,K2 $INCLUDE KERDEF (NLIST) $NLIST K2=J K1=I 100 IF (XFROM(K1).NE.EOS) THEN XTO(K2)=XFROM(K1) K2=K2+1 K1=K1+1 GOTO 100 ENDIF XTO(K2)=EOS RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION SDATA(X) C C Sends a data packet to other KERMIT C C JL 4/18/84 17:15 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 X,NUM,LEN,BUFILL,STATUS,RPACK,TNUM,TV1 INTEGER ITEMP,LUN IF(NUMTRY.GT.MAXTRY)THEN WRITE(20,*) ' SDATA- MAXTRY exceeded - Status = A' SDATA=BIGA CALL RATCLOSE(FD) CALL RATCLOSE(MOREFD) RETURN ELSE NUMTRY=NUMTRY+1 ENDIF C TNUM=N TV1=BIGD CALL SPACK(TV1,TNUM,SIZE,PACKET) ;send that data packet IF(HOSTON.EQ.NO)THEN ;if we are running in local LUN=LOCALOUTFD WRITE(LUN,100)TNUM ;mode , display the current sequence # ENDIF C STATUS=RPACK(LEN,NUM,RECPKT) ;get the reply C C The next statements is to make sure we are not one packet C ahead of other KERMIT, it will happen if other KERMIT send a NAK C (due to time-out detection feature) before we send the first C SINIT packet C IF((STATUS.EQ.BIGY).AND.(N.EQ.(NUM+1)))THEN STATUS=RPACK(LEN,NUM,RECPKT) ENDIF SDATA=STATE ; Default to STATE C IF(STATUS.EQ.BIGN)THEN ;we got a NAK IF(N.NE.(NUM-1))THEN SDATA=STATE ;to the right sequence # RETURN ENDIF ELSE IF(STATUS.EQ.BIGY)THEN ;we got a ACK IF(N.NE.NUM)THEN SDATA=STATE ;but, it was for the last pac RETURN ENDIF NUMTRY=0 ITEMP=N+1 N=MOD(ITEMP,64) ;increment frame sequence num SIZE=BUFILL(PACKET) ;fill up more data onto buffe IF(SIZE.EQ.EOF)THEN ;we got EOF on the sending SDATA=BIGZ ;disk file, change state so RETURN ;we can sent an EOF packet ENDIF SDATA=BIGD ;we send the DATA packet, sen RETURN ELSE IF(STATUS.EQ.BAD)THEN ;we got a checksum error SDATA=STATE ;try it again RETURN ELSE SDATA=BIGA ;we got unknown packet type o WRITE(20,*) ' SDATA- BAD Packet - Chksum?? - Status = A' CALL RATCLOSE(MOREFD) CALL RATCLOSE(FD) RETURN ENDIF ;an error type packet RETURN 100 FORMAT(' ','Packet # ',I4) END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION SENDSW(X) C C Send this group of files. C C JL 4/18/84 17:15 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST COMMON /XBYTE/ XNEW,XCOUNT,XLIN(264),XEOF INTEGER*2 XSTATUS,SDATA,SFILE,SEOF,SINIT,SBREAK,X INTEGER*2 TV1,TV2,TV3,TV4 STATE=BIGS XNEW=YES XCOUNT=1 XEOF=NO N=0 NUMTRY=0 STATUS=YES SENDSW=NO ; Default to failed SEND C 100 IF (STATUS.EQ.YES) THEN IF(STATE.EQ.BIGD)THEN ;send a data packet STATE=SDATA(X) ELSE IF(STATE.EQ.BIGF)THEN ;send a file header STATE=SFILE(X) ELSE IF(STATE.EQ.BIGZ)THEN ;send a EOF header STATE=SEOF(X) ELSE IF(STATE.EQ.BIGS)THEN ;send a SINIT packet STATE=SINIT(X) ELSE IF(STATE.EQ.BIGB)THEN ;send a BREAK packet STATE=SBREAK(X) ELSE IF(STATE.EQ.BIGC)THEN SENDSW=YES ;file transfer complete RETURN ELSE IF(STATE.EQ.BIGA)THEN ;file transfer failed SENDSW=NO TV1=BIGE TV2=N TV3=0 TV4=0 CALL SPACK(TV1,TV2,TV3,TV4) ;send a ERROR pkt RETURN ELSE STATUS=NO SENDSW=NO ;file transfer failed ENDIF GOTO 100 ENDIF RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION SEOF(X) C C Send an EOF packet to the other KERMIT C C JL 4/18/84 17:16 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 NUM,LEN,STATUS,RPACK,X,TNUM,TEMP,XY INTEGER*2 ALIN(132),AONE,BONE,TV1,TV2,TV3,TV4 INTEGER*2 XREAD INTEGER ITEMP,MAXLEN,LUN CHARACTER*12 FileName DATA MAXLEN/12/ XREAD=0 C IF(NUMTRY.GT.MAXTRY)THEN SEOF=BIGA ;exceeded max. # of re-try, giv CALL RATCLOSE(FD) CALL RATCLOSE(MOREFD) WRITE(20,*) ' SEOF - MAXTRY exceeded - Status = A' RETURN ELSE NUMTRY=NUMTRY+1 ENDIF AONE=1 BONE=1 TNUM=N TV1=BIGZ TV2=0 TV3=0 CALL SPACK(TV1,TNUM,TV2,TV3) ;send an EOF packet to other KE STATUS=RPACK(LEN,NUM,RECPKT) ;what is its reply ?? SEOF=STATE ; Default to State IF(STATUS.EQ.BIGN)THEN ;we got an NAK IF(N.NE.(NUM-1))THEN ;if NAK for last packet SEOF=STATE RETURN ENDIF ELSE IF(STATUS.EQ.BIGY)THEN ;we got a NAK IF(N.NE.NUM)THEN SEOF=STATE ;but it was for the last packet RETURN ENDIF NUMTRY=0 CALL RATCLOSE(FD) ;close the sending disk file ch ITEMP=N+1 N=MOD(ITEMP,64) TEMP=DGETLIN(TXTFILE,FILNAME,MOREFD) ;Another SEND? IF(TEMP.EQ.EOF)THEN ;no, all directory files sent CALL RATCLOSE(MOREFD) ; close up shop SEOF=BIGB ;change state to break transmission RETURN ELSE FD=AOPEN(FMode,FILNAME,XREAD) ;At least one more IF (FD.EQ.BAD) then ;Can' open for send IF(HOSTON.EQ.NO)THEN LUN=LOCALOUTFD CALL PACK(FILNAME,FileName) WRITE(LUN,*) ' File not found--> ',FileName ENDIF TEMP=YES 100 IF (TEMP.EQ.YES) THEN ; Try next filename XY=DGETLIN(TXTFILE,ALIN,MOREFD) IF(X.EQ.EOF)THEN ;no more files SEOF=BIGB ;change state to send BREAK CALL RATCLOSE(MOREFD) ;close directory ch RETURN ELSE ; At least one more file to send CALL SCOPY(ALIN,AONE,FILNAME,BONE) FD=AOPEN(TXTFILE,FILNAME,XREAD) ;Exists?? IF(FD.NE.BAD)TEMP=NO ;file exists ENDIF GOTO 100 ; Loop till Good File or End ENDIF SEOF=BIGF RETURN ELSE SEOF=BIGF ;Yes, change state to send RETURN ;the file header packet ENDIF ENDIF ELSE IF(STATUS.EQ.BAD)THEN ;there was a checksum e SEOF=STATE ;try it again RETURN ELSE WRITE(20,*) ' SEOF - Unexpected packet got - Status = A' SEOF=BIGA ; Unexpected Packet got CALL RATCLOSE(FD) CALL RATCLOSE(MOREFD) RETURN ENDIF RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE SETBAUD(CH,FNAME) C C Set a global variable to selected baud rate, it will not C goes into affect until executed by SETPORT routine, then it C will remain in effect for the rest of the session C C (This routine would be used by the P-E in LOCAL mode, C which is currently unimplemented.) C (look for it in Version 3.0) C C JL 4/27/84 11:16 C----------------------------------------------------------------- C$INCLUDE KERCOM (NLIST) $NLIST C COMMON /MUX/ VRAWCOOK,VPARITY,VPORT,VBAUD,VENQACK,VXONXOFF,VREST C$INCLUDE KERDEF (NLIST) $NLIST C IF(SPEED.EQ.300)THEN C VBAUD=60B C ELSE IF(SPEED.EQ.1200)THEN C VBAUD=70B C ELSE IF(SPEED.EQ.2400)THEN C VBAUD=110B C ELSE IF(SPEED.EQ.4800)THEN C VBAUD=120B C ELSE IF(SPEED.EQ.9600)THEN C VBAUD=130B C ELSE C WRITE(LUN,100) C ENDIF RETURN C 100 FORMAT(' ','Invalid baud rate; not supported in CCC OS/32') END $NLIST C----------------------------------------------------------------- SUBROUTINE SETCOOK(CH,FNAME) C C Set a global variable to cook mode to be used later by C sequential read in TGETCH function routine, have no effect C on the tty setting itself C C (This routine would be used by the P-E in LOCAL mode, C which is currently unimplemented.) C (look for it in Version 3.0) C C JL 4/27/84 11:05 C------------------------------------------------------------------ C IMPLICIT INTEGER*2 (A-Z) C COMMON /MUX/ VRAWCOOK,VPARITY,VPORT,VBAUD,VENQACK, C + VXONXOFF,VREST C$INCLUDE KERDEF (NLIST) $NLIST C VRAWCOOK=400B RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE SETPAR(CH,FNAME) C C Set a global variable to selected parity bit, it will not C go into affect until it is executed by the SETPORT subroutine C it will remain in effect for the rest of the session C (This routine would be used by the P-E in LOCAL mode, C which is currently unimplemented.) C (look for it in Version 3.0) C C JL 4/27/84 11:12 C----------------------------------------------------------------- C$INCLUDE KERCOM (NLIST) $NLIST C COMMON /MUX/ VRAWCOOK,VPARITY,VPORT,VBAUD,VENQACK, C + VXONXOFF,VREST C$INCLUDE KERDEF (NLIST) $NLIST C IF(PARITY.EQ.1)THEN C VPARITY=600B C ELSE IF(PARITY.EQ.2)THEN C VPARITY=100B C ELSE IF(PARITY.EQ.5)THEN C VPARITY=200B C ELSE C WRITE(LUN,100) C ENDIF RETURN C 100 FORMAT(' ','Invalid parity; not supported in CCC OS/32') END $NLIST C----------------------------------------------------------------- SUBROUTINE SETPORT(CH,FNAME) C C This routine would normally enable a user to selected which C port to used for remote file transfer, but it will not C be implemented in the CCC OS/32 system. This routine is instead C being used for setting the proper port configuration such as C baud rate, parity, xon/xoff,enq/ack, stop bits, bpc etc C C (This routine would be used by the P-E in LOCAL mode, C which is currently unimplemented.) C (look for it in Version 3.0) C C JL 4/27/84 11:20 C----------------------------------------------------------------- C$INCLUDE KERCOM (NLIST) $NLIST C COMMON /MUX/ VRAWCOOK,VPARITY,VPORT,VBAUD,VENQACK, C + VXONXOFF,VREST C$INCLUDE KERDEF (NLIST) $NLIST C INTEGER*2 CH,FNAME(1) C INTEGER*2 ICODE,ICNWD,IPARM1,IA,IB C C ICODE=3 C ICNWD=CH+3000B C IPARM1=VPARITY+VBAUD+VENQACK+VREST C C CALL EXEC(ICODE,ICNWD,IPARM1) ;set portID based on selected bits C CALL ABREG(IA,IB) ;see page 2-23 of multiplex manual C WRITE(LUN,100)IA,IB C IPARM1=VXONXOFF C ICNWD=CH+3400B C CALL EXEC(ICODE,ICNWD,IPARM1) ;set port configuration to enable C CALL ABREG(IA,IB) ;XON/XOFF see pages 2-23 of mult. m C WRITE(LUN,100)IA,IB C100 FORMAT(' ','Values of IA & IB in SETPORT are ',A2,' = ',A2) RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE SETRAW(CH,FNAME) C C Set a global variable to raw mode to be used later by C sequential read in TGETCH function routine, have no effect C on the tty setting itself C C (This routine would be used by the P-E in LOCAL mode, C which is currently unimplemented.) C (look for it in Version 3.0) C C JL 4/27/84 11:05 C----------------------------------------------------------------- C IMPLICIT INTEGER*2 (A-Z) C COMMON /MUX/ VRAWCOOK,VPARITY,VPORT,VBAUD,VENQACK, C + VXONXOFF,VREST C$INCLUDE KERDEF (NLIST) C VRAWCOOK=100B RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION SFILE(X) C C Send the filename to other KERMIT C C JL 4/18/84 17:19 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST COMMON /XBYTE/ XNEW,XCOUNT,XLIN(264),XEOF INTEGER*2 NUM,LEN,COUNT,RPACK,BUFILL,X,TNUM INTEGER*2 TV1,TV2,ALIN(132),AONE,BONE INTEGER ITEMP,LUN CHARACTER*12 FileName AONE=1 BONE=1 CALL SCOPY(FILNAME,AONE,ALIN,BONE) C IF(HOSTON.EQ.NO)THEN LUN=LOCALOUTFD CALL PACK(ALIN,FileName) WRITE(LUN,*) ' Sending file--> ',FileName ;Local mode ENDIF C IF(NUMTRY.GT.MAXTRY)THEN WRITE(20,*) ' SFILE - Exceeded MAXTRY - Status = A' SFILE=BIGA ;exceeded max. # of re-try CALL RATCLOSE(FD) CALL RATCLOSE(MOREFD) RETURN ;gives up ELSE NUMTRY=NUMTRY+1 ;try it one more time ENDIF LEN=1 100 IF (FILNAME(LEN).NE.EOS) THEN ;determine the length of f LEN=LEN+1 GOTO 100 ENDIF C LEN=LEN-2 ;len is the length of file TNUM=N TV1=BIGF CALL SPACK(TV1,TNUM,LEN,FILNAME) ;Send filename to Remote Kermit STATUS=RPACK(LEN,NUM,RECPKT) SFILE=STATE ; Default SFILE return to current state C IF(STATUS.EQ.BIGN)THEN ;we got a NAK IF(N.NE.(NUM-1))THEN SFILE=STATE RETURN ENDIF ELSE IF(STATUS.EQ.BIGY)THEN ;we got a ACK IF(N.NE.NUM)THEN SFILE=STATE RETURN ENDIF NUMTRY=0 ITEMP=N+1 N=MOD(ITEMP,64) XNEW=YES XCOUNT=1 XEOF=NO SIZE=BUFILL(PACKET) ;fill up a buffer full of bytes SFILE=BIGD ;change state to sent data RETURN ELSE IF(STATUS.EQ.BAD)THEN ;we got a checksum error SFILE=STATE RETURN ELSE SFILE=BIGA ;we got an error or unexpec WRITE(20,*) ' SFILE - Unexpected Packet type - Status = A' CALL RATCLOSE(MOREFD) ;CLOSE DIRECTORY CH CALL RATCLOSE(FD) ;CLOSE SENDING FD RETURN ;packet type ENDIF RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE SHELP C C Types out the content of the HelpFile C C JL 4/18/84 17:20 C DM/PM 3/85 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 STATUS,GETLIN,ALIN(264),TEMPCH,XREAD INTEGER*2 AOPEN,GETKEYBD,NLINES,TV ;DM 1/85 INTEGER LUN LOGICAL HELPON CHARACTER*2 CRLF ;DM 1/85 CHARACTER*25 CPROMPT DATA CRLF/Z0D0A/ ; Carriage Return/Line Feed DATA CPROMPT/'RETURN to continue...'/ XREAD=0 LUN=LOCALOUTFD TEMPCH=15 ; Kermit.HLP opened as LU 15 in Kermit.CSS INQUIRE(TEMPCH,OPENED=HELPON) ; Check availability IF (.NOT.HELPON) THEN WRITE(LUN,1000) RETURN ELSE REWIND(TEMPCH) CALL TPUTCH(LF,LOCALOUTFD) ; LineFeed at top of Display NLINES=0 100 IF (DGETLIN(TXTFILE,ALIN,TEMPCH).NE.EOF) THEN ;Next HELPline CALL PUTLIN(ALIN,LOCALOUTFD) ; (PUTSCRN) CALL PUTSTRNG (LOCALOUTFD,2,CRLF) NLINES=NLINES+1 IF (NLINES.GT.21) THEN CALL PUTSTRNG (LOCALOUTFD,2,CRLF) CALL PUTSTRNG(LOCALOUTFD,25,CPROMPT) TV=GETKEYBD(ALIN,LOCALINFD) ; Wait for RETURN CALL PUTSTRNG (LOCALOUTFD,2,CRLF) NLINES=0 ENDIF GOTO 100 ENDIF ENDIF RETURN 1000 FORMAT(/' Kermit.HLP not available....wing it, ok??') END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION SINIT(X) C C Send an initial packet for the first connection C state what my parameters are C C JL 4/18/84 17:20 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 NUM,LEN,STATUS,RPACK,X,TNUM,TEMP,XY INTEGER*2 ALIN(264),AONE,BONE,TV1,TV2,XREAD INTEGER*2 MOREFILE(132),DGETLIN INTEGER ITEMP,MAXLEN DATA MAXLEN/12/ MOREFILE(1)=BIGM MOREFILE(2)=BIGO MOREFILE(3)=BIGR MOREFILE(4)=BIGE MOREFILE(5)=BIGF MOREFILE(6)=BIGI MOREFILE(7)=BIGL MOREFILE(8)=BIGE MOREFILE(9)=LF MOREFILE(10)=EOS XREAD=0 IF(NUMTRY.GT.MAXTRY)THEN SINIT=BIGA ;exceeded max # of re-try , gi WRITE(20,*) ' SINIT - MAXTRY exceeded - Status = A' RETURN ELSE NUMTRY=NUMTRY+1 ;try it again ENDIF C AONE=1 BONE=1 CALL SPAR(PACKET) ;get my requirement parameters TNUM=N TV1=BIGS TV2=9 ; Basic Kermit + 8-Bit Quoting,CheckSumType,Repeat CALL SPACK(TV1,TNUM,TV2,PACKET) ;send my parameters requiremen STATUS=RPACK(LEN,NUM,RECPKT) ;what was the reply ?? SINIT=STATE ; Default RETURN value to State IF (DEBUGON.EQ.YES) & WRITE(20,*) ' SINIT - STATUS = ',STATUS,' STATE= ',STATE C IF(STATUS.EQ.BIGN)THEN ;NAK it IF(N.NE.(NUM-1))THEN IF (DEBUGON.EQ.YES)WRITE(20,*) 'SINIT - N.NE.(NUM-1)' SINIT=STATE ;try it again RETURN ENDIF ELSE IF(STATUS.EQ.BIGY)THEN ;ACK it IF(N.NE.NUM)THEN ;but it was for previous packet SINIT=STATE ;re-try it again RETURN ENDIF CALL RPAR(RECPKT) ;get requirements of other Kermit NUMTRY=0 ITEMP=N+1 N=MOD(ITEMP,64) MOREFD=AOPEN(TXTFILE,MOREFILE,XREAD) ;open Dir File IF(MOREFD.EQ.BAD)THEN ;directory file does not exis WRITE(20,*) ' SINIT - Directory file Unopenable' SINIT=BIGA RETURN ENDIF TEMP=YES 100 IF (TEMP.EQ.YES) THEN ;Do until File got or End XY=DGETLIN(TXTFILE,ALIN,MOREFD) ;Get DIR Fname IF(XY.EQ.EOF)THEN ;we have reach an EOF SINIT=BIGA ;nothing to send at all CALL RATCLOSE(MOREFD) ;close directory file RETURN ELSE CALL SCOPY(ALIN,AONE,FILNAME,BONE) FD=AOPEN(FMode,FILNAME,XREAD) ;Open R File IF(FD.NE.BAD)TEMP=NO ;yes it does ENDIF GOTO 100 ; Loop till File got or EOF ENDIF SINIT=BIGF ;change state to sent file header pac RETURN ELSE IF(STATUS.EQ.BAD)THEN ;checksum error detected WRITE(20,*) ' SINIT - Checksum error - State=',STATE SINIT=STATE ;try it again RETURN ELSE SINIT=BIGA WRITE(20,*) ' SINIT - BAD OPEN - STATE = ',STATE ENDIF RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE SKIPBL(LIN, I) C----------------------------------------------------------------- INTEGER*2 LIN(1) INTEGER*2 I 23000 IF(.NOT.(LIN(I) .EQ. 32 .OR. LIN(I) .EQ. 9))GOTO 23001 I = I + 1 GOTO 23000 23001 CONTINUE RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE SPACK(XTYPE,NUM,LEN,XDATA) C C Send this packet to the remote KERMIT C C JL 4/18/84 17:22 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 XDATA(132),XTYPE,NUM,LEN,CH INTEGER*2 TV2,TV3, LENTMP INTEGER*2 BUFFER(132),I,IER,COUNT,TOCHAR,CHKSUM2 INTEGER ITEMP,TV1,CHKSUM CH=RMTOUTFD ;this is the channel to send packe I=1 ;out on, start with the first byte C 100 IF (I.LE.PAD) THEN ;send out padchar if need CALL TPUTCH(PADCHAR,CH) I=I+1 GOTO 100 ENDIF COUNT=1 BUFFER(COUNT)=SOH COUNT=COUNT+1 LENTMP=LEN+3 CHKSUM=TOCHAR(LENTMP) BUFFER(COUNT)=TOCHAR(LENTMP) COUNT=COUNT+1 CHKSUM=CHKSUM+TOCHAR(NUM) BUFFER(COUNT)=TOCHAR(NUM) COUNT=COUNT+1 CHKSUM=CHKSUM+XTYPE BUFFER(COUNT)=XTYPE COUNT=COUNT+1 C DO 200 I=1,LEN ;copy the content of packet info BUFFER(COUNT)=XDATA(I) ;calculate the checksum COUNT=COUNT+1 CHKSUM=CHKSUM+XDATA(I) 200 CONTINUE C TV1=IAND(CHKSUM,192) ** TV2=TV1/64 ITEMP=(TV1/64) + CHKSUM CHKSUM2=IAND(ITEMP,63) BUFFER(COUNT)=TOCHAR(CHKSUM2) COUNT=COUNT+1 BUFFER(COUNT)=LF ;PUTLIN expects LF as terminator BUFFER(COUNT+1)=EOS C Send packet out in one shot CALL PUTLIN(BUFFER,CH) ; Send Packet to Remote Kermit RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE SPAR(XDATA) C C JL 5/4/84 15:00 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 CTL,TOCHAR,XZERO,MYTIME INTEGER*2 XDATA(1) I=1 ;Relative Index XZERO=0 XDATA(I)=TOCHAR(PAKSIZ) XDATA(I+1)=TOCHAR(MYTIMOUT) XDATA(I+2)=TOCHAR(MYPAD) ; No. Pad Chars needed XDATA(I+3)=CTL(MYPCHAR) ; Pad Character XDATA(I+4)=TOCHAR(MYEOL) XDATA(I+5)=MYQUOTE IF (MYQUOT8B.EQ.YES) THEN XDATA(I+6)=Q8BCHR ELSE XDATA(I+6)=BIGN ENDIF XDATA(I+7)=DIG1 ; Basic Block Checksum used XDATA(I+8)=BLANK ; No Repeat char. encoding done RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE SQUIT C C Exit from Kermit-CO, with aplomb. C C JL 4/18/84 17:25 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST INTEGER LUN LUN=LOCALOUTFD WRITE(LUN,100) RETURN 100 FORMAT(/' Kermit-CO signing off...') END $NLIST C----------------------------------------------------------------- SUBROUTINE SRECEIVE(IRecL) C C Set up TTY line before calling for RECSW routine C C JL 4/30/84 15:30 (PM 3/16/86) C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 STATUS,AOPEN,X,BELL,IRecL INTEGER LUIN, LUOT,UserRecL,NSects, DefRecL(3), MaxRecL(3) CHARACTER RecLenCH*4 COMMON /NEWREC/ UserRecL,NSects DATA DefRecL/80,256,256/ ; ASCII, BINARY, CONTIGUOUS default DATA MaxRecL/256,256,256/ ; ASCII, BINARY ,CONTIGUOUS default C C For CONTIG files,get number sectors to allocate; otherwise get C get Record Length to use for TEXT,BINARY LUIN = LOCALINFD LUOT = LOCALOUTFD IF (FMode.EQ.CONFILE) THEN ; Get no. sectors for CONTIG IF (IRecL.GT.0) THEN NSects = IRecL ELSE 50 WRITE(LUOT,4000) ; Insist on a Sector count READ(LUIN,1030) RecLenCH NSects=CTOI(RecLenCH,K) IF (NSects.LE.0) GOTO 50 ENDIF UserRecL=DefRecL(FMode) ;Rec size fixed for CONTIG WRITE(LUOT,4010) NSects ELSE ; TEXT, BINARY IF (IRecL.LE.0.OR.IRecL.GT.MaxRecL(FMode)) THEN 100 WRITE(LUOT,2000) MaxRecL(FMode) READ (LUIN,1030) RecLenCH UserRecL=CTOI(RecLenCH,K) IF (UserRecL.LE.0) THEN UserRecL=DefRecL(FMode) ; Default if non-numeric ELSE IF (UserRecL.LT.10.OR. & UserRecL.GT.MaxRecL(FMode)) GOTO 100 ENDIF ELSE UserRecl=IRecL ENDIF WRITE(LUOT,2010) UserRecL ENDIF BELL=7 Q8BCHR=AMPER ; Initialize 8-Bit quote before each INIT C Enter 'Receive State Switching' routine.....only 'HOSTON' is C currently implemented IF(HOSTON.EQ.YES)THEN ; 'REMOTE HOST' mode WRITE(LUOT,2020) STATUS=RECSW(X) ELSE WRITE(LUOT,1020)UserRecL ; 'LOCAL' mode CCCC CALL SETRAW(RMTINFD,RMTTTY) ;put this TTY into RAW mode CCCC CALL SETPAR(RMTOUTFD,RMTTTY) ;set user selected parity CCCC CALL SETBAUD(RMTOUTFD,RMTTTY) ;set user selected baud rate CCCC CALL SETPORT(RMTINFD,RMTTTY) STATUS=RECSW(X) CCCC CALL SETCOOK(RMTINFD,RMTTTY) ;put TTY back into COOK mode CCCC CALL TPUTCH(BELL,LOCALSLU) CCCC CALL TPUTCH(BELL,LOCALSLU) IF(STATUS.EQ.YES)THEN WRITE(LUOT,1000) ELSE WRITE(LUOT,1010) ENDIF ENDIF IF (FNamChng.EQ.YES) THEN WRITE(LUOT,3000) FNamChng=NO ENDIF RETURN 1000 FORMAT(' ','File transfer COMPLETED') 1010 FORMAT(' ','File transfer FAILED') 1020 FORMAT(/' Using Record length = ',I4) 1030 FORMAT(A4) 2000 FORMAT(/' Enter RECEIVE file Record size: (10 ->',I4,')') 2010 FORMAT(/' Record size used = ',I4,' bytes') 2020 FORMAT(/' Return to Local Kermit & SEND...'/) 3000 FORMAT(' Received file name(s) made unique.') 4000 FORMAT(/' Enter Sectors to allocate for CONTIGUOUS file:') 4010 FORMAT(/' Number of Contiguous sectors allocated = ',I4) END $NLIST C----------------------------------------------------------------- SUBROUTINE SSEND(ALIN) C C Set up remote line and directory file before calling SENDSW C C JL 4/18/84 17:30 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 ALIN(1),ISEND(5),HoldFlag INTEGER*2 MOREFILE(132),A1,Z1,STATUS,TEMP,I INTEGER*2 FLAG,B1,TPNAME(264),CH1,CH2,XREAD,XWRITE INTEGER*2 TLINE(264),X,BELL,FINDLN INTEGER MAXLEN,RecLen,LUN INTEGER UserRecL, NSects, DefRecL CHARACTER*12 FileName COMMON /NEWREC/ UserRecL,NSects DATA ISEND /83,69,78,68,10002/, MAXLEN/12/, DefRecL/80/ LUN=LOCALOUTFD MOREFILE(1)=BIGM MOREFILE(2)=BIGO MOREFILE(3)=BIGR MOREFILE(4)=BIGE MOREFILE(5)=BIGF MOREFILE(6)=BIGI MOREFILE(7)=BIGL MOREFILE(8)=BIGE MOREFILE(9)=LF MOREFILE(10)=EOS UserRecL=DefRecL ; Initialize for Temporary files RecLen=UserRecL BELL=7 Q8BCHR=AMPER ; Initialize 8-bit quote before INIT XREAD=0 XWRITE=1 C A1=1 FLAG=FINDLN(ALIN,ISEND,A1,Z1) A1=Z1+1 CALL SKIPBL(ALIN,A1) IF(ALIN(A1).EQ.LF)THEN WRITE(LUN,1020) RETURN ENDIF C IF(ALIN(A1).EQ.ATSIGN)THEN ;is it a directory file A1=A1+1 B1=1 TPNAME(1)=LF TPNAME(2)=EOS CALL SCOPY(ALIN,A1,TPNAME,B1) CH1=AOPEN(TXTFILE,TPNAME,XREAD) ;open that directory IF(CH1.EQ.BAD)THEN ;does it exist ? CALL PACK(TPNAME,FileName) WRITE(LUN,1030) FileName WRITE(20,1030) FileName RETURN ENDIF CALL REMOVE(MOREFILE) ;yes, remove temp file HoldFlag=FNamChek FNamChek=NO CH2=AOPEN(TXTFILE,MOREFILE,XWRITE) ;open it for writing FNamChek=HoldFlag ; Restore Collision flag IF(CH2.EQ.BAD)THEN CALL PACK(MOREFILE,FileName) WRITE(LUN,1040) FileName WRITE(20,1040) FileName CALL RATCLOSE(CH1) RETURN ENDIF 100 IF (DGETLIN(TXTFILE,TLINE,CH1).NE.EOF)THEN ;copy Dir CALL DPUTLIN(TXTFILE,TLINE,CH2,RecLen) ;into temp file GOTO 100 ; Loop till out of Filenames ENDIF CALL RATCLOSE(CH1) ;close directory channel CALL RATCLOSE(CH2) ;close temporary file ELSE B1=1 ;it is not a directory CALL SCOPY(ALIN,A1,TPNAME,B1) CALL REMOVE(MOREFILE) ;remove temporary file HoldFlag=FNamChek ; Save File RENEW FNamChek=NO CH1=AOPEN(TXTFILE,MOREFILE,XWRITE) ;open it for writing FNamChek=HoldFlag IF(CH1.EQ.BAD)THEN CALL PACK(MOREFILE,FileName) WRITE(LUN,1040) FileName WRITE(20,1040) FileName ENDIF CH2=AOPEN(FMode,TPNAME,XREAD) ;does that single source IF(CH2.EQ.BAD)THEN ;file exist ?? CALL PACK(TPNAME,FileName) WRITE(LUN,1060) FileName WRITE(20,1060) FileName CALL RATCLOSE(CH1) RETURN ELSE CALL RATCLOSE(CH2) ;yes it does ENDIF CALL DPUTLIN(TXTFILE,TPNAME,CH1,RecLen) ;write name of CALL RATCLOSE(CH1) ;single source file and the temp file ENDIF C IF(HOSTON.EQ.YES)THEN ; 'REMOTE HOST' mode WRITE(LUN,1010) CALL XDELAY(DELAY) STATUS=SENDSW(X) ;send the requested file ELSE CC CALL SETRAW(RMTINFD,RMTTTY) ; LOCAL mode CC CALL SETPAR(RMTOUTFD,RMTTTY) ; (These routines left CC CALL SETBAUD(RMTOUTFD,RMTTTY) ; for reference in CC CALL SETPORT(RMTINFD,RMTTTY) ; using LOCAL mode) STATUS=SENDSW(X) CC CALL SETCOOK(RMTINFD,RMTTTY) CC CALL TPUTCH(BELL,LOCALSLU) CC CALL TPUTCH(BELL,LOCALSLU) IF(STATUS.EQ.YES)THEN WRITE(LUN,1000) 'COMPLETED' ELSE WRITE(LUN,1000) 'FAILED' ENDIF ENDIF RETURN 1000 FORMAT(/' File transfer ',A) 1010 FORMAT(/' Return to Local Kermit & RECEIVE...'/) 1020 FORMAT(/' Proper format is SEND FILENAME or SEND @FILENAME') 1030 FORMAT(/' Source of directory file not found --> ',A,' ') 1040 FORMAT(/' Unable to open temporary file --> ',A,' ') 1060 FORMAT(/' Source file does not exist --> ',A,' ') END $NLIST C------------------------------------------------------------------ SUBROUTINE SSERVER C C -- Put Kermit-CO into SERVER mode. In this state, it simply waits C for a remote Kermit to intiate some activity. Every 30 seconds, C a NAK packet is sent down the line in case a remote Kermit has C stalled. SERVER mode is active until shut down by remote user. C C Implementation projected for Version 3.0: C GET fname - Kermit-CO send requested file C RECEIVE - Kermit-CO responds to File Header packet C by preparing to receive files C BYE,FINISH - Deactivate SERVER, return to LOCAL mode C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER LUN LUN=LOCALOUTFD WRITE(LUN,1000) RETURN 1000 FORMAT(/' The SERVER is currently not at yr service...') END $NLIST C----------------------------------------------------------------- SUBROUTINE SSET(ALIN) C C Parse and set various selectable parameters C C JL 5/1/84 10:00 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 ALIN(1) INTEGER*2 A1,T1,T2,T3,T4,T5,T6,TV,CHARTOI INTEGER*2 FLAG1,FLAG2,FLAG3,FLAG4,FLAG5,FLAG6,FLAG7 INTEGER*2 FLAG8,FLAG9,FLAG10,FLAG11,FLAG12,FLAG13,FLAG14,FLAG15 INTEGER*2 FLAG16, FLAG17, FLAG18 INTEGER*2 F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13,F14,F15, 1 F16,F17,F18 INTEGER*2 Z1,Z2,Z3,Z4,Z5,Z6,Z7,Z8,Z9,Z10,Z11,Z12,Z13,Z14,Z15, 1 Z16,Z17,Z18 C INTEGER*2 IBAUD(5),IDELAY(6),IPARITY(7),IODD(4) INTEGER*2 IEVEN(5),IMARK(5),ISPACE(6),INONE(5) INTEGER*2 IIBM(4),ION(3),IOFF(4),IESCAPE(7),ILINE(5) INTEGER*2 IPROMPT(7),IPACKET(7),ISOH(4),IEOL(4) INTEGER*2 IQUOTE(8),ISET(4),IPAD(4),INPAD(6),I8BIT(5) INTEGER*2 IDEBUG(6),IFILE(5),ITEXT(5),IBIN(7),IFCHEK(6) INTEGER*2 ISEOR(5),ICR(3),ILF(3),ICRLF(5),ICONTIG(7) INTEGER LUN C C Various keyword character strings initialized here DATA IBAUD /66,65,85,68,10002/ DATA IDELAY /68,69,76,65,89,10002/ DATA IPARITY /80,65,82,73,84,89,10002/ DATA IODD /79,68,68,10002/ DATA IEVEN /69,86,69,78,10002/ DATA IMARK /77,65,82,75,10002/ DATA ISPACE /83,80,65,67,69,10002/ DATA INONE /78,79,78,69,10002/ DATA IIBM /73,66,77,10002/ DATA ION /79,78,10002/ DATA IOFF /79,70,70,10002/ DATA IESCAPE /69,83,67,65,80,69,10002/ DATA ILINE /76,73,78,69,10002/ DATA IPROMPT /80,82,79,77,80,84,10002/ DATA IPACKET /80,65,67,75,69,84,10002/ DATA ISOH /83,79,72,10002/ DATA IEOL /69,79,76,10002/ DATA IQUOTE /77,89,81,85,79,84,69,10002/ DATA INPAD /78,80,65,68,83,10002/ ; 'NPADS' DATA IPAD /80,65,68,10002/ ; 'PAD' character DATA I8BIT /56,66,73,84,10002/ ; '8BIT' DATA IDEBUG /68,69,66,85,71,10002/ ; 'DEBUG' DATA IFILE /70,73,76,69,10002/ ; 'FILE' DATA ITEXT /84,69,88,84,10002/ ; 'TEXT' DATA IBIN /66,73,78,65,82,89,10002/ ; 'BINARY' DATA IFCHEK /70,67,72,69,75,10002/ ; 'FCHEK' DATA ISEOR /83,69,79,82,10002/ ; 'SEOR' DATA ICR /67,82,10002/ ; 'CR' DATA ILF /76,70,10002/ ; 'LF' DATA ICRLF /67,82,76,70,10002/ ; 'CRLF' DATA ICONTIG /67,79,78,84,73,71,10002/ ; 'CONTIG' C................................................................ LUN=LOCALOUTFD ; Get Output LU of CON: C Convert various keyword character string into integer array C and add an extra EOS to the end of the integer array A1=1 FLAG1=FINDLN(ALIN,ISET,A1,Z1) ;look for the keyword SET A1=A1+1 CALL SKIPBL(ALIN,A1) ;skip any blanks any tabs TV=A1 F1=TV C FLAG1=FINDLN(ALIN,IBAUD,F1,Z1) ;look for BAUD F2=TV FLAG2=FINDLN(ALIN,IDELAY,F2,Z2) ;look for DELAY F3=TV FLAG3=FINDLN(ALIN,IPARITY,F3,Z3) ;look for PARITY F4=TV FLAG4=FINDLN(ALIN,IIBM,F4,Z4) ;look for IBM F5=TV FLAG5=FINDLN(ALIN,IESCAPE,F5,Z5) ;look for ESCAPE F6=TV FLAG6=FINDLN(ALIN,ILINE,F6,Z6) ;look for LINE F7=TV FLAG7=FINDLN(ALIN,IPROMPT,F7,Z7) ;look for PROMPT F8=TV FLAG8=FINDLN(ALIN,IPACKET,F8,Z8) ;look for PACKET F9=TV FLAG9=FINDLN(ALIN,ISOH,F9,Z9) ;look for SOH FLAG10=NO Z10=0 F11=TV FLAG11=FINDLN(ALIN,IQUOTE,F11,Z11) ;look for QUOTE F12=TV FLAG12=FINDLN(ALIN,INPAD,F12,Z12) ;look for NPAD F13=TV FLAG13=NO Z13=0 CCC FLAG13=FINDLN(ALIN,IPAD,F13,Z13) ;look for PAD (3/19/86 OFF) F14=TV FLAG14=FINDLN(ALIN,I8BIT,F14,Z14) ;look for 8BIT F15=TV FLAG15=FINDLN(ALIN,IDEBUG,F15,Z15) ;look for DEBUG F16=TV FLAG16=FINDLN(ALIN,IFILE,F16,Z16) ;look for FILE 3/19/86 F17=TV FLAG17=FINDLN(ALIN,IFCHEK,F17,Z17) ;look for FCHEK 4/4/86 F18=TV FLAG18=FINDLN(ALIN,ISEOR,F18,Z18) ;look for SEOR 4/16/86 C IF(FLAG1.EQ.YES)THEN ;set baud IF(SBAUD.EQ.YES)THEN IF(HOSTON.EQ.YES)THEN WRITE(LUN,100) RETURN ENDIF F1=Z1+1 CALL SKIPBL(ALIN,F1) ;skip any blanks or tabs X=CHARTOI(ALIN,F1) IF(X.EQ.300)THEN ; BAUD = 300 SPEED=300 ELSE IF(X.EQ.1200)THEN ; BAUD = 1200 SPEED=1200 ELSE IF(X.EQ.2400)THEN ; BAUD = 2400 SPEED=2400 ELSE IF(X.EQ.4800)THEN ; BAUD = 4800 SPEED=4800 ELSE IF(X.EQ.9600)THEN ; BAUD = 9600 SPEED=9600 ELSE WRITE(LUN,102) RETURN ENDIF ELSE WRITE(LUN,103) ENDIF ELSE IF(FLAG2.EQ.YES)THEN ;set delay IF(HOSTON.EQ.NO)THEN WRITE(LUN,104) RETURN ENDIF F2=Z2+1 CALL SKIPBL(ALIN,F2) X=CHARTOI(ALIN,F2) IF(X.LT.0)THEN WRITE(LUN,105) RETURN ELSE IF(X.GT.30)THEN WRITE(LUN,106) DELAY=30 RETURN ELSE DELAY=X RETURN ENDIF ELSE IF(FLAG3.EQ.YES)THEN ;set parity IF(SPARITY.EQ.YES)THEN **** IF(HOSTON.EQ.YES)THEN **** WRITE(LUN,108) **** RETURN ; in LOCAL mode **** ENDIF F3=Z3+1 CALL SKIPBL(ALIN,F3) ;skip any blanks or tabs TV=F3 T1=FINDLN(ALIN,IEVEN,TV,T6) ;look for EVEN TV=F3 T2=FINDLN(ALIN,IODD,TV,T6) ;look for ODD TV=F3 T3=FINDLN(ALIN,ISPACE,TV,T6);look for SPACE TV=F3 T4=FINDLN(ALIN,IMARK,TV,T6) ;look for MARK TV=F3 T5=FINDLN(ALIN,INONE,TV,T6) ;look for NONE IF(T1.EQ.YES)THEN PARITY=1 ;set parity EVEN TMode=TXTFILE ; 7 bit ASCII transfer MYQUOT8B=YES ;Set 8 bit prefixing for EVEN ELSE IF(T2.EQ.YES)THEN PARITY=2 ;set parity ODD TMode = TXTFILE ; 7 bit ASCII MYQUOT8B=YES ;Set 8bit prefix ELSE IF(T3.EQ.YES)THEN WRITE(LUN,110) RETURN ELSE IF(T4.EQ.YES)THEN WRITE(LUN,111) RETURN ELSE IF(T5.EQ.YES)THEN PARITY=5 ;set parity NONE TMode = BINFILE ; 8 bit IMAGE transfer MYQUOT8B=NO ;Turn off 8bit prefixing ELSE WRITE(LUN,112) RETURN ENDIF ELSE WRITE(LUN,113) RETURN ENDIF ELSE IF(FLAG4.EQ.YES)THEN ;set IBM IF(HOSTON.EQ.YES)THEN WRITE(LUN,114) RETURN ENDIF F4=Z4+1 CALL SKIPBL(ALIN,F4) ;skip any blanks or tabs TV=F4 TV1=FINDLN(ALIN,ION,TV,T6) ;look for keyword ON TV=F4 TV2=FINDLN(ALIN,IOFF,TV,T6) ;look for keyword OFF IF(TV1.EQ.YES)THEN IBMON=YES ;set IBM flag ON ELSE IF(TV2.EQ.YES)THEN IBMON=NO ;set IBM flag OFF ELSE WRITE(LUN,116) RETURN ENDIF ELSE IF(FLAG5.EQ.YES)THEN ;set escape IF(HOSTON.EQ.YES)THEN WRITE(LUN,117) RETURN ENDIF F5=Z5+1 CALL SKIPBL(ALIN,F5) ;skip any blanks or tabs X=CHARTOI(ALIN,F5) IF((X.GT.0).AND.(X.LT.32))THEN ESCHAR=X ELSE WRITE(LUN,119) RETURN ENDIF ELSE IF(FLAG6.EQ.YES)THEN ;set remote line IF(HOSTON.EQ.YES)THEN WRITE(LUN,120) RETURN ENDIF IF(SPORT.EQ.YES)THEN ;is set line supported ?? F6=Z6+1 CALL SKIPBL(ALIN,F6) ;skip any blanks or tab A1=1 CALL SCOPY(ALIN,F6,RMTTTY,A1) ;store remote filename RETURN ELSE WRITE(LUN,121) RETURN ENDIF ELSE IF(FLAG7.EQ.YES)THEN ;set IBM prompt IF(HOSTON.EQ.YES)THEN WRITE(LUN,123) RETURN ENDIF F7=Z7+1 CALL SKIPBL(ALIN,F7) ;skip any blanks or tabs X=CHARTOI(ALIN,F7) IF((X.EQ.EOL).OR.(X.EQ.SOH))THEN WRITE(LUN,125) RETURN ELSE IF((X.GT.0).AND.(X.LT.32))PROMPT=X ENDIF ELSE IF(FLAG8.EQ.YES)THEN ;set packet size F8=Z8+1 CALL SKIPBL(ALIN,F8) X=CHARTOI(ALIN,F8) IF((X.GT.30).AND.(X.LT.95))THEN PAKSIZ=X RETURN ELSE WRITE(LUN,126) RETURN ENDIF ELSE IF(FLAG9.EQ.YES)THEN ;set SOH F9=Z9+1 CALL SKIPBL(ALIN,F9) ;skip any blanks or tabs X=CHARTOI(ALIN,F9) IF(HOSTON.EQ.YES)THEN IF(X.EQ.EOL)THEN WRITE(LUN,127) RETURN ELSE IF((X.GT.0).AND.(X.LT.32))THEN SOH=X RETURN ELSE WRITE(LUN,128) RETURN ENDIF ENDIF ELSE IF((X.EQ.EOL).OR.(X.EQ.PROMPT))THEN WRITE(LUN,129) RETURN ELSE IF((X.GT.0).AND.(X.LT.32))THEN SOH=X RETURN ELSE WRITE(LUN,128) RETURN ENDIF ENDIF ENDIF ELSE IF(FLAG10.EQ.YES)THEN ;set EOL F10=Z10+1 CALL SKIPBL(ALIN,F10) X=CHARTOI(ALIN,F10) IF(HOSTON.EQ.YES)THEN IF(X.EQ.SOH)THEN WRITE(LUN,133) RETURN ELSE IF((X.GT.0).AND.(X.LT.32))THEN MYEOL=X RETURN ELSE WRITE(LUN,134) RETURN ENDIF ENDIF ELSE IF((X.EQ.SOH).OR.(X.EQ.PROMPT))THEN WRITE(LUN,136) RETURN ELSE IF((X.GT.0).AND.(X.LT.32))THEN MYEOL=X RETURN ELSE WRITE(LUN,134) RETURN ENDIF ENDIF ENDIF ELSE IF(FLAG11.EQ.YES)THEN ;set myquote F11=Z11+1 CALL SKIPBL(ALIN,F11) X=CHARTOI(ALIN,F11) IF((X.GT.32).AND.(X.LT.127))THEN MYQUOTE=X RETURN ELSE WRITE(LUN,140) RETURN ENDIF C...................................added 12/20/84 - PM ELSE IF(FLAG12.EQ.YES)THEN ;set MYPAD (Number of Pad chars) F12=Z12+1 CALL SKIPBL(ALIN,F12) X=CHARTOI(ALIN,F12) IF((X.GE.0).AND.(X.LT.101))THEN ; 100 Pad chr Max MYPAD=X RETURN ELSE WRITE(LUN,143) RETURN ENDIF ELSE IF(FLAG13.EQ.YES)THEN ;set MYPCHAR F13=Z13+1 CALL SKIPBL(ALIN,F13) X=CHARTOI(ALIN,F13) MYPCHAR=X RETURN ELSE IF(FLAG14.EQ.YES)THEN ; Set 8-Bit Quoting On/Off F14=Z14+1 CALL SKIPBL(ALIN,F14) TV=F14 T1=FINDLN(ALIN,ION,TV,T6) ; look for ON TV=F14 T2=FINDLN(ALIN,IOFF,TV,T6) ; look for OFF IF (T1.EQ.YES) THEN ; Turn 8-Bit Quoting ON MYQUOT8B=YES ; Set 8-Bit quoting ON Q8BCHR=AMPER ELSE IF (T2.EQ.YES) THEN ; Turn 8-Bit Quoting OFF MYQUOT8B=NO ; by setting to 'N' Q8BCHR=0 ELSE WRITE(LUN,145) ; ERROR ENDIF ENDIF RETURN ELSE IF(FLAG15.EQ.YES)THEN ; Set DEBUGON On/Off F15=Z15+1 CALL SKIPBL(ALIN,F15) TV=F15 T1=FINDLN(ALIN,ION,TV,T6) ; look for ON TV=F15 T2=FINDLN(ALIN,IOFF,TV,T6) ; look for OFF IF (T1.EQ.YES) THEN ; Turn DEBUG ON DEBUGON=YES ELSE IF (T2.EQ.YES) THEN ; Turn DEBUG OFF DEBUGON=NO ; by setting to 'N' ELSE WRITE(LUN,146) ; ERROR ENDIF ENDIF RETURN ELSE IF(FLAG16.EQ.YES)THEN ; Set FILE Mode Text/Binary/Contig F16=Z16+1 CALL SKIPBL(ALIN,F16) TV=F16 T1=FINDLN(ALIN,ITEXT,TV,T6) ; TEXT? TV=F16 T2=FINDLN(ALIN,IBIN,TV,T6) ; BINARY? TV=F16 T3=FINDLN(ALIN,ICONTIG,TV,T6) ; CONTIGUOUS? IF (T1.EQ.YES) THEN FMode = TXTFILE ; TEXT/ASCII (SSEND) mode SendEOR = 3 ; EOR = CR/LF ELSE IF (T2.EQ.YES) THEN FMode = BINFILE ; BINARY/IMAGE mode SendEOR = NO ; EOR = None ELSE IF (T3.EQ.YES) THEN FMode = CONFILE ;CONTIG/IMAGE mode SendEOR = NO ;EOR=None ELSE WRITE(LUN,147) ENDIF ENDIF ENDIF ELSE IF(FLAG17.EQ.YES)THEN ; Set FCHEK On/Off F17=Z17+1 CALL SKIPBL(ALIN,F17) TV=F17 T1=FINDLN(ALIN,ION,TV,T6) ; look for ON TV=F17 T2=FINDLN(ALIN,IOFF,TV,T6) ; look for OFF IF (T1.EQ.YES) THEN ; Turn File Name Check ON FNamChek=YES ELSE IF (T2.EQ.YES) THEN ; Turn FNamChek OFF FNamChek=NO ; by setting to 'N' ELSE WRITE(LUN,149) ; ERROR ENDIF ENDIF RETURN ELSE IF(FLAG18.EQ.YES)THEN ; Set SEOR = NONE,CR,LF,CRLF F18=Z18+1 CALL SKIPBL(ALIN,F18) TV=F18 T1=FINDLN(ALIN,INONE,TV,T6) ; look for NONE IF (T1.EQ.YES) THEN SendEOR=NO ; No End-of-Rec delimiter used ELSE TV=F18 T1=FINDLN(ALIN,ICRLF,TV,T6) ; look for CRLF IF (T1.EQ.YES) THEN SendEOR=3 ; CRLF for End-of-Record ELSE TV=F18 T1=FINDLN(ALIN,ILF,TV,T6) ; look for LF IF (T1.EQ.YES) THEN SendEOR=2 ; LF used for End-of-Record ELSE TV=F18 T1=FINDLN(ALIN,ICR,TV,T6) ; look for CR IF (T1.EQ.YES) THEN SendEOR=1 ; CR used for End-of-Record ELSE WRITE(LUN,150) ; Error in SEOR parm ENDIF ENDIF ENDIF ENDIF RETURN ELSE WRITE(LUN,142) RETURN ENDIF RETURN C............................................................. 100 FORMAT(/' Baud rate setting not supported in Remote Host') 102 FORMAT(/' Invalid or Unsupported baud rate selected') 103 FORMAT(/' Kermit-CO 2.1 does not support Baud selection') 104 FORMAT(/' Delay setting not valid in Local Host mode') 105 FORMAT(/' Invalid delay setting') 106 FORMAT(/' Maximium Delay is 30 seconds') C 108 FORMAT(/' Parity setting not supported in Remote Host mode') 110 FORMAT(/' SPACE parity not supported') 111 FORMAT(/' MARK parity not supported') 112 FORMAT(/' Parity selected not valid') 113 FORMAT(/' Parity setting not supported in this system') 114 FORMAT(/' SET IBM ON/OFF not supported in Remote Host mode') 116 FORMAT(/' Invalid SET IBM mode selected') 117 FORMAT(/' Escape setting not valid in Remote Host mode') 119 FORMAT(/' Escape character must be between 0 & 32') 120 FORMAT(/' SET LINE not valid in Remote Host mode') 121 FORMAT(/' SET remote line not supported in Remote Host mode') 123 FORMAT(/' SET IBM PROMPT not valid in Remote Host mode') 125 FORMAT(/' Invalid: in conflict with EOL or SOH') 126 FORMAT(/' Packet size must be between 31 & 94') 127 FORMAT(/' In conflict with EOL') 128 FORMAT(/' SOH must be between 0 & 32') 129 FORMAT(/' In conflict with EOL or IBM prompt') 133 FORMAT(/' In conflict with SOH') 134 FORMAT(/' EOL must be between 0 & 32') 136 FORMAT(/' EOL in conflict with SOH or IBM prompt') 140 FORMAT(/' QUOTE char must be between 32 & 127') 142 FORMAT(/' A SET parameter is incorrect') 143 FORMAT(/' Number of Pads must be between 0 & 100') 145 FORMAT(/' 8 Bit quoting can be only ON or OFF') 146 FORMAT(/' DEBUG can be only ON or OFF') 147 FORMAT(/' File mode must be TEXT, BINARY, or CONTIG') *148 FORMAT(/' BINARY mode requires a NO PARITY line') 149 FORMAT(/' File Name Check (FCHEK) can be only ON or OFF') 150 FORMAT(/' Send EOR (SEOR) must be NONE, CR, LF, or CRLF') END $NLIST C----------------------------------------------------------------- SUBROUTINE SSTATUS C C Output the status and values of variables C C JL 4/19/84 9:03 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST CHARACTER*3 DBG,QUOTE8,FCK,ITSON,ITSOFF CHARACTER*5 PARTYPE(5),SEORTYPE(4) CHARACTER*6 FileType(3) INTEGER LUN, ITemp DATA ITSON/' ON'/, ITSOFF/'OFF'/ DATA PARTYPE/' EVEN',' ODD','SPACE',' MARK',' NONE'/ DATA SEORTYPE/' NONE',' CR',' LF',' CRLF'/ DATA FileType/' TEXT','BINARY','CONTIG'/ LUN=LOCALOUTFD ; for CON: output QUOTE8=ITSOFF IF (MYQUOT8B.EQ.YES) QUOTE8=ITSON DBG=ITSOFF IF (DEBUGON.EQ.YES) DBG=ITSON FCK=ITSOFF IF (FNamChek.EQ.YES) FCK=ITSON IF(HOSTON.EQ.YES)THEN ;we are running in remote host mode WRITE(LUN,107) WRITE(LUN,111) PARTYPE(PARITY) WRITE(LUN,124) FileType(FMode) WRITE(LUN,125) FCK WRITE(LUN,122) QUOTE8 ; PM 1/84/84 WRITE(LUN,104) DELAY WRITE(LUN,100) PAKSIZ WRITE(LUN,121) MYPAD ; No. Pad Chars requested PM 11/84 ITemp=SendEOR+1 WRITE(LUN,126) SEORTYPE(ITemp) WRITE(LUN,123) DBG ; DM 1/84 IF (DEBUGON.EQ.YES) THEN ;Display only if DEBUG on WRITE(LUN,102)MYQUOTE WRITE(LUN,101)SOH WRITE(LUN,103)MYEOL IF(STATE.EQ.BIGC)THEN WRITE(LUN,108) 'Complete' ELSE WRITE(LUN,108) ' Aborted' ENDIF ENDIF ELSE WRITE(LUN,110) WRITE(LUN,106)SPEED WRITE(LUN,105)ESCHAR IF(IBMON.EQ.YES)THEN WRITE(LUN,117) ITSON WRITE(LUN,119)PROMPT ELSE WRITE(LUN,117) ITSOFF ENDIF WRITE(LUN,100)PAKSIZ WRITE(LUN,111) PARTYPE(PARITY) WRITE(LUN,116) WRITE(LUN,121) MYPAD ; PM 12/20/84 WRITE(LUN,122) QUOTE8 WRITE(LUN,111) PARTYPE(PARITY) WRITE(LUN,123) DBG WRITE(LUN,124) FileType(FMode) WRITE(LUN,125) FCK WRITE(LUN,122) QUOTE8 ; PM 1/84/84 ITemp=SendEOR+1 WRITE(LUN,126) SEORTYPE(ITemp) IF (DEBUGON.EQ.YES) THEN WRITE(LUN,103)MYEOL WRITE(LUN,102)MYQUOTE WRITE(LUN,101)SOH IF(STATE.EQ.BIGC)THEN WRITE(LUN,108) 'Complete' ELSE WRITE(LUN,108) ' Aborted' ENDIF ENDIF CCCCC WRITE(LUN,120) MYPCHAR ; PM 12/20/84 ENDIF RETURN C................................................................. 110 FORMAT(/' ','LOCAL Kermit mode in effect:'/) 107 FORMAT(/' ','REMOTE Kermit Host in effect:'/) 116 FORMAT(' ',' Remote TTY line used is ??') 100 FORMAT(' ',' Packet Size - ',4X,I4) 101 FORMAT(' ',' Start-of-packet char - ',4X,I4) 102 FORMAT(' ',' Control char prefix - ',4X,I4) 103 FORMAT(' ',' End-of-packet char - ',4X,I4) 104 FORMAT(' ',' Send Delay (seconds) - ',4X,I4) 105 FORMAT(' ',' Escape Character - ',4X,I4) 106 FORMAT(' ',' Baud Rate - ',4X,I4) 108 FORMAT(' ',' Transfer State - ',A8) 111 FORMAT(' ',' Parity - ',3X,A5) 117 FORMAT(' ',' IBM Flag - ',5X,A3) 119 FORMAT(' ',' IBM Prompt - ',4X,I4) C 120 FORMAT(' ',' Pad Character - ',4X,I4) 121 FORMAT(' ',' Number of Pad chars - ',4X,I4) 122 FORMAT(' ',' 8th Bit Prefixing - ',5X,A3) 123 FORMAT(' ',' Debug Packet Recording - ',5X,A3) 124 FORMAT(' ',' File Mode - ',2X,A6) 125 FORMAT(' ',' File Name Check - ',5X,A3) 126 FORMAT(' ',' Send End-of-Rec char - ',3X,A5) END $NLIST C ----------------------------------------------------------------- INTEGER*2 FUNCTION TOCHAR(CH) C C JL 4/19/84 9:05 C ----------------------------------------------------------------- INTEGER*2 CH $INCLUDE KERDEF (NLIST) $NLIST TOCHAR=CH+BLANK RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION UNCHAR(CH) C C JL 4/19/84 9:05 C----------------------------------------------------------------- INTEGER*2 CH $INCLUDE KERDEF (NLIST) $NLIST UNCHAR=CH-BLANK RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE UPPER(ALIN,BLIN) C C Convert lower (ALIN) to upper case (BLIN) C C JL 4/19/84 C----------------------------------------------------------------- INTEGER*2 ALIN(1),BLIN(1),A1 $INCLUDE KERDEF (NLIST) $NLIST A1=1 100 IF (ALIN(A1).NE.EOS) THEN IF((ALIN(A1).GT.96).AND.(ALIN(A1).LT.123))THEN BLIN(A1)=ALIN(A1)-32 ELSE BLIN(A1)=ALIN(A1) ENDIF A1=A1+1 GOTO 100 ENDIF BLIN(A1)=EOS RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE VERIFY(TFILE) C C Verify that the filename is usable under OS/32 C -Checks for XXXXXXXX.XXX filename format, turns C illegal characters (and periods in excess of 1) to 'X', C and limits name to 12 characters...... C However, VERIFY does not deal with cases where the FileName C has more than 8 Characters before the period (e.g. 'XXXXXXXXX') C or more than 3 chars after. (e.g. XX.XXXX) C These illegal names will be flagged in AOPEN, and the C attempted SEND/RECEIVE will be terminated. Individual C sites may want to customize this routine to preference. C C JL 4/19/84 9:05 C PM 2/85 C----------------------------------------------------------------- INTEGER*2 INFILE(132),OUTFILE(132),TFILE(1) INTEGER*2 AONE,BONE,TEMP,PERFREQ,ICHAR,MAXLEN/12/ $INCLUDE KERDEF (NLIST) $NLIST AONE=1 BONE=1 TEMP=1 PERFREQ=0 CALL UPPER(TFILE,INFILE) DO 100 I=1,132 TFILE(I)=BLANK OUTFILE(I)=BLANK 100 CONTINUE C C Loop thru characters in File Name... Replace illegal chars with 'A' C (OS/32 Format = XXXXXXXX.XXX) (More Exacting checks can be added) 200 ICHAR=INFILE(TEMP) ;Current Character IF ((ICHAR.NE.LF).AND.(ICHAR.NE.EOS)) THEN IF((ICHAR.GT.64).AND.(ICHAR.LT.91))GOTO 290 ; Letter?? IF((ICHAR.GT.47).AND.(ICHAR.LT.58))GOTO 290 ; Number?? IF (ICHAR.EQ.PERIOD) THEN IF (PERFREQ.LT.1) THEN ; First Period?? PERFREQ=PERFREQ+1 ; Only one Period per filename GOTO 290 ENDIF ENDIF ICHAR=BIGX ; 'X' for illegal chars 290 OUTFILE(TEMP)=ICHAR ; Further checking here TEMP=TEMP+1 GOTO 200 ; Next character ENDIF C C OS/32 allows maximium of 12 characters per filename C (First character may not be numeric) IF((OUTFILE(1).GT.47).AND.(OUTFILE(1).LT.58)) THEN OUTFILE(1)=BIGX ENDIF OUTFILE(MAXLEN+1)=EOS ; Limit Name to legal max CALL SCOPY(OUTFILE,AONE,TFILE,BONE) RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE XDELAY(X) C C Delay the calling program for x seconds C C JL 4/25/84 13:40 C----------------------------------------------------------------- INTEGER ISTAT,IX INTEGER*2 X IX=X CALL WAIT(IX,2,ISTAT) ; Wait X seconds RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION GETLIN(ALIN,CH) C C Read a line from the channel and unpack it C - A Formatted (ASCII) or Unformatted (IMAGE) read may be C done, depending on value of 'TMode' C C PM 4/86 C JL 5/8/84 10:40 AM C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER ITEMP*4,ICHRS*2(66) ; Full-Word align ICHRS INTEGER IPCBLK(6),IOS,LUN,LEN,MAXREC,LENX, TV4 INTEGER IWAIT,IREAD(2),RXOPT(2),IWRIT(2),WXOPT(2),XXON INTEGER*2 ALIN(1),CH,INPCHAR,ACOUNT,TV2,INPCNT CHARACTER CHARINP*2,TV1*2 EQUIVALENCE (INPCHAR,CHARINP) EQUIVALENCE (TV1,TV2) PARAMETER (MAXREC=130) ; Maximum Rec size written DATA XXON/Z11000000/, IWAIT/Z08/ C 7 bit, Even parity, ASCII DATA IREAD(1)/Z49/,RXOPT(1)/Z38000000/ ;ASCII,Echo off DATA IWRIT(1)/Z29/,WXOPT(1)/Z00000000/ ;ASCII C 8 bit, No parity, IMAGE DATA IREAD(2)/Z59/,RXOPT(2)/Z10000000/ ;IMAGE,Echo off DATA IWRIT(2)/Z39/,WXOPT(2)/Z00000000/ ;IMAGE C.............................................................. C Initialize the ALIN array DO 10 I=1,132 10 ALIN(I)=0 ACOUNT=0 LEN=MAXREC ; Max line that can be read LUN=CH ; *2 to *4 variable for SYSIO C C Send out XON to trigger send (Just testing...this would be used to C emulate IBM protocol, make micro await "Prompt"(DC10 before sending) C CALL SYSIO(IPCBLK2,IWRIT(TMode),LUN,XXON,1,0,WXOPT(TMode)) ;XON C C.....WAIT for last PUTLIN to finish CALL SYSIO(IPCBLK,IWAIT,LUN,0,0,0,Y'00000000') ;WAIT I/O done C Read in Line/Packet from CON: until MYEOL encountered (CR) IF (TMode.EQ.TXTFILE) THEN ; ASCII CALL SYSIO(IPCBLK,Y'49',LUN,ICHRS(1),LEN,0,Y'38000000') ;GL ELSE ; IMAGE CALL SYSIO(IPCBLK,Y'59',LUN,ICHRS(1),LEN,0,Y'10000000') ;GL ENDIF CALL IOERR(IPCBLK,IOS) ; Check status IF (IOS.NE.0) THEN WRITE(20,100) IOS GOTO 900 ENDIF C LEN = IPCBLK(5) ; Get length of last receive IF (DEBUGON.EQ.YES) THEN ; Write out packet if DEBUG on WRITE(20,120) LEN,(ICHRS(I),I=1,LEN/2) ENDIF C C Unpack line into ALIN..................UPDATE 9/15/85 (D.MacPhee) LENX = LEN/2 + 1 DO 205 I=1,LENX INPCHAR = ICHRS(I) DO 200 K=1,2 TV2 =0 TV1(2:2) = CHARINP(K:K) IF (PARITY.NE.5) THEN ; IF EVEN/ODD, strip 8th bit TV4=TV2 TV2=IAND(TV4,127) ENDIF IF (TV2.EQ.MYEOL) GOTO 210 ACOUNT = ACOUNT + 1 ALIN(ACOUNT) = TV2 200 CONTINUE 205 CONTINUE GOTO 890 ; MYEOL not found C Here if MYEOL found 210 ALIN(ACOUNT+1)=LF ALIN(ACOUNT+2)=EOS ; Mark end of input line GETLIN=OK RETURN ; Successful end-of-operation C.....................................UPDATE 9/15/85 (David MacPhee) C Here if No MYEOL on current packet 890 WRITE (20,*) ' GETLIN Error: Never found MYEOL' 900 GETLIN=EOF ; Error on read RETURN 100 FORMAT(' GETLIN - BAD I/O: ',I4) 120 FORMAT(' ',I3,' RPACK=',63A2) END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION GETKEYBD(ALIN,CH) C C Read a line from the Keyboard and unpack it C C PM 8/84 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER*2 ALIN(1),CH,ACOUNT,TV2,INPCHAR,SPBS,PRMPT INTEGER IPCBLK(6),IREAD(2),RXOPT(2),IOS,LUN,MAXREC,ITEMP,TV4 CHARACTER CHARINP*2,TV1*2 EQUIVALENCE (INPCHAR,CHARINP) EQUIVALENCE (TV1,TV2) PARAMETER (MAXREC=130) ; Maximum Rec size read DATA SPBS/Z2008/, PRMPT/Z3E00/ ; SP/BS '>' C 7 Bit, Even parity, Formatted DATA IREAD(1)/Z49/,RXOPT(1)/Z00000000/ ;ASCII Rd,Echo on (CON:) C 8 Bit, No parity, IMAGE DATA IREAD(2)/Z59/,RXOPT(2)/Z00000000/ ;IMAGE Rd,Echo ON (CON:) C............................................................... C Initialize the ALIN array DO 100 I=1,132 100 ALIN(I)=0 ACOUNT=0 LUN=CH ; *2 to *4 variable for SYSIO C C Read in Characters one at a time until MYEOL encountered DO 200 I=1,MAXREC IF (TMode.EQ.TXTFILE) THEN ; ASCII CALL SYSIO(IPCBLK,Y'49',LUN,INPCHAR,1,0,Y'00000000') ;GK ELSE ; IMAGE CALL SYSIO(IPCBLK,Y'59',LUN,INPCHAR,1,0,Y'00000000') ;GK ENDIF CALL IOERR(IPCBLK,IOS) ; Check status IF (IOS.GT.0) GOTO 900 TV2=0 TV1(2:2)=CHARINP(1:1) ; Shift Byte to right IF (PARITY.NE.5) THEN ; IF EVEN/ODD, strip 8th bit TV4=TV2 TV2=IAND(TV4,127) ENDIF IF (TV2.EQ.MYEOL) GOTO 210 ; End input when found IF (TV2.EQ.BACKSPACE) THEN ; Allow destructive BS IF (ACOUNT.GT.0) THEN ALIN(ACOUNT)=0 ACOUNT=ACOUNT-1 ; BS encountered only on CON: CALL PUTSTRNG(LOCALOUTFD,2,SPBS) ;erase BS'd char ELSE CALL PUTSTRNG(LOCALOUTFD,1,PRMPT) ;Stop at Prompt ENDIF GOTO 200 ; Skip BS under any condition ENDIF ACOUNT=ACOUNT+1 ALIN(ACOUNT)=TV2 200 CONTINUE 210 ALIN(ACOUNT+1)=LF ALIN(ACOUNT+2)=EOS ; Mark end of input line GETKEYBD=OK RETURN ; Successful end-of-operation 900 GETKEYBD=EOF ; Error on read RETURN RETURN END $NLIST C----------------------------------------------------------------- SUBROUTINE PUTLIN(ALIN,CH) C C Pack a line and send it down the channel to remote KERMIT. C - A Formatted (ASCII) or Unformatted (IMAGE) write may be C done, depending on value of 'TMode' C C JL 4/25/84 14:15 ** PM 11/84 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER LEN*4,BLIN*2(132) ; FullWord align BLIN INTEGER IPCBLK(6), LUN, IOS INTEGER IWRIT(2), WXOPT(2), IWAIT INTEGER*2 ALIN(1),CH,TV2 INTEGER*2 LEFT,RIGHT,WHICHS,STATUS,ACOUNT,BCOUNT INTEGER*2 TCOUNT,INPCHAR,OUTCHAR CHARACTER CHARINP*2,CHAROUT*2 INTEGER TV1,ITEMP,ITEMP2,RITECR,LEFTCR EQUIVALENCE(INPCHAR,CHARINP) EQUIVALENCE(OUTCHAR,CHAROUT) DATA IWAIT/Z08/ C 7 bit, Even parity, Formatted DATA IWRIT(1)/Z21/,WXOPT(1)/Z00000000/ ;ASCII Write(No Wait) C 8 bit, No parity, IMAGE DATA IWRIT(2)/Z31/,WXOPT(2)/Z00000000/ ;IMAGE Write(No Wait) C......................................................... LEFT=1 RIGHT=2 WHICHS=LEFT ACOUNT=1 BCOUNT=1 TCOUNT=1 LUN=CH 901 IF (ALIN(ACOUNT).NE.LF) THEN IF(WHICHS.EQ.LEFT)THEN INPCHAR=ALIN(ACOUNT) OUTCHAR=0 CHAROUT(1:1)=CHARINP(2:2) ; Byte to Left side of BLIN BLIN(BCOUNT)=OUTCHAR WHICHS=RIGHT ELSE OUTCHAR=BLIN(BCOUNT) INPCHAR=ALIN(ACOUNT) CHAROUT(2:2)=CHARINP(2:2) ; Byte to Right side of BLIN BLIN(BCOUNT)=OUTCHAR WHICHS=LEFT BCOUNT=BCOUNT+1 ENDIF ACOUNT=ACOUNT+1 TCOUNT=ACOUNT GOTO 901 ENDIF C IF(WHICHS.EQ.LEFT)THEN INPCHAR=CR OUTCHAR=0 CHAROUT(1:1)=CHARINP(2:2) BLIN(BCOUNT)=OUTCHAR ELSE OUTCHAR=BLIN(BCOUNT) INPCHAR=CR CHAROUT(2:2)=CHARINP(2:2) BLIN(BCOUNT)=OUTCHAR ENDIF LEN=TCOUNT IF (DEBUGON.EQ.YES) THEN ; Save packet if DEBUG mode WRITE(20,120) LEN,(BLIN(I),I=1,LEN/2) ENDIF IF (TMode.EQ.TXTFILE) THEN ; ASCII CALL SYSIO(IPCBLK,Y'21',LUN,BLIN(1),LEN,0,Y'00000000') ;PL ELSE ; IMAGE CALL SYSIO(IPCBLK,Y'31',LUN,BLIN(1),LEN,0,Y'00000000') ;PL ENDIF CALL IOERR(IPCBLK,IOS) IF (IOS.NE.0) THEN WRITE(20,*) ' PUTLIN - SYSIO Error - ',IOS ENDIF RETURN 120 FORMAT(' ',I3,' SPACK=',63A2) END $NLIST C----------------------------------------------------------------- SUBROUTINE PUTSTRNG(LUNX,LenStr,Str) C Write out a character string to CON: (LU 1) using SYSIO C (For special cases: Prompt line I/O mostly) C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER LUN,IPCBLK(6),LenStr,IWRIT(2),WXOPT(2),Str*2(50) INTEGER*2 LUNX C 7 Bit, Even parity, Formatted Write DATA IWRIT(1)/Z29/,WXOPT(1)/Z00000000/ ;ASCII Write C 8 Bit, No Parity, IMAGE Write DATA IWRIT(2)/Z39/,WXOPT(2)/Z00000000/ ;IMAGE Write LUN=LUNX CALL SYSIO(IPCBLK,IWRIT(TMode),LUN,Str(1),LenStr,0,WXOPT(TMode)) RETURN END $NLIST C----------------------------------------------------------------- INTEGER*2 FUNCTION TGETCH(XCHAR,CH) C C Get a CHAR from the TTY without echoing it C For use with IBM mode - Not implemented as of 3/11/85 C C JL 4/25/84 14:20 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER LUN*4,IBUF*2,XCHAR*2,XCHAR2*2,CH*2 INTEGER IPCBLK(6),IREAD(2),IOS,LEN,RXOPT(2) CHARACTER IBUF2*2,XCHAR3*2 EQUIVALENCE(XCHAR2,XCHAR3) EQUIVALENCE(IBUF,IBUF2) C 7 Bit, Even parity, ASCII DATA IREAD(1)/Z49/, RXOPT(1)/Z38000000/ ;ASCII Rd, Echo off C 8 Bit, No parity, IMAGE DATA IREAD(2)/Z59/, RXOPT(2)/Z10000000/ ;IMAGE Rd, Echo off LUN=CH IBUF=0 IF (TMode.EQ.TXTFILE) THEN ; ASCII CALL SYSIO(IPCBLK,Y'49',LUN,IBUF,1,0,Y'38000000') ;TGETCH ELSE ; IMAGE CALL SYSIO(IPCBLK,Y'59',LUN,IBUF,1,0,Y'10000000') ;TGETCH ENDIF CALL IOERR(IPCBLK,IOS) ; Check O/P status IF (IOS.LE.0) THEN XCHAR2=0 XCHAR3(2:2)=IBUF2(1:1) ; Shift byte rightmost XCHAR=XCHAR2 TGETCH=OK RETURN ELSE ; Error on Input TGETCH=OK RETURN ENDIF END $NLIST C----------------------------------------------------------------- SUBROUTINE TPUTCH(XCHAR,CH) C C Output a character to the TTY line C (For use with IBM I/O. Not used as of 3/1/85) C C JL 4/25/84 14:25 C----------------------------------------------------------------- $INCLUDE KERCOM (NLIST) $NLIST $INCLUDE KERDEF (NLIST) $NLIST INTEGER LUN*4,IBUF*4,CH*2,XCHAR*2,XCHAR2*2 ; PW INTEGER IPCBLK(6),IOS,IWRIT(2),WXOPT(2),IWAIT CHARACTER XCHAR3*2,IBUF2*4 EQUIVALENCE(XCHAR2,XCHAR3) EQUIVALENCE(IBUF,IBUF2) DATA IWAIT/Z08/ C 7 bit, Even parity, Formatted DATA IWRIT(1)/Z29/,WXOPT(1)/Z00000000/ ;ASCII Write C 8 bit, No parity, IMAGE DATA IWRIT(2)/Z39/,WXOPT(2)/Z00000000/ ;IMAGE Write C.............................................................. LUN=CH IBUF=0 XCHAR2=XCHAR IBUF2(1:1)=XCHAR3(2:2) ; Shift Byte leftmost C.....WAIT for I/O to finish on CON: CCC CALL SYSIO(IPCBLK,IWAIT,LUN,0,0,0,Y'00000000') ;WAIT I/O done C WRite out the character IF (TMode.EQ.TXTFILE) THEN ; ASCII CALL SYSIO(IPCBLK,Y'29',LUN,IBUF,1,0,Y'00000000') ;TPUTCH ELSE ; IMAGE CALL SYSIO(IPCBLK,Y'39',LUN,IBUF,1,0,Y'00000000') ;TPUTCH ENDIF CALL IOERR(IPCBLK,IOS) IF (IOS.NE.0) THEN WRITE (20,*) 'TPUTCH - SYSIO error - ',IOS ENDIF RETURN END $NLIST C--------------------------------------------------------------- SUBROUTINE DATETIME(Day,Sec,FDay,FSec) C C Return formatted Date and Time of Right Now. C--------------------------------------------------------------- INTEGER Today(3), Now(3) CHARACTER Day*6, Sec*6, FDay*8, FSec*8, Char*2 CALL DATE(Today) Day = '000000' L = 2 DO 10 I=1,3 Char = ITOC(Today(I),K) IF (K.EQ.1) THEN Day(L:L) = Char ELSE Day(L-1:L) = Char ENDIF 10 L = L + 2 FDay = Day(3:4)//'/'//Day(5:6)//'/'//Day(1:2) ; MM/DD/YY CALL TIME(Now) Sec = '000000' L=2 DO 20 I=1,3 Char = ITOC(Now(I),K) IF (K.EQ.1) THEN Sec(L:L) = Char ELSE Sec(L-1:L) = Char ENDIF 20 L = L + 2 FSec = Sec(1:2)//':'//Sec(3:4)//':'//Sec(5:6) RETURN END