home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
extra
/
perkin.ftn
< prev
next >
Wrap
Text File
|
2020-01-01
|
138KB
|
4,076 lines
$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 <CR> 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 <CR>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 <CR> 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