UUCJEFF@ECNCDC.BITNET (08/19/87)
c MODEM7-type program to send and
c receive files with checksums or CRC and automatic
c re-transmission of bad blocks.
c translated to VAX Fortran V3.0 from TMODEM.C by
c and enhanced according to time-outs and CRC
C in XMODEM50.ASM
c J.James Belonis II
c Physics Hall FM-15
c University of Washington
c Seattle, WA 98195
c
c TMODEM.C written by Richard Conn, Eliot Moss, and Lauren
c Weinstein
c
c 6/30/83 Modified, restructured, and VAX/VMS text file
c conversion added by Richard Conn
c 1/17/83 touched up filename display and comments.
c 1/14/83 including timeouts and CTRL-X cancellation
c and CRC capability
c
c keeps a log file of error messages ( deletes it if no errors )
c sets terminal driver to eightbit, passall
c may need altypeahd if faster than 1200 baud works to 9600 baud at least.
c needs PHY_IO privilege for passall ? apparently not on UWPhys VAX
c nor on ACC VAX
c many debugging statements left in as comments
c declare variables
include 'QIO.DCK/list'
character*80 line, file, workf
integer sloc, worklen
logical filedel
common /filest/filedel
integer errorcount
common /err/errorcount
integer high,low
common /crcval/high,low
logical crc
integer checksum
common /checks/checksum,crc
equivalence (checksum,checksumbyte)
equivalence (ic,c)
c define ascii characters
parameter NUL=0 !ignore at SOH time
parameter SOH=1 !start of header for sector
parameter EOT=4 !end of transfer
parameter ACK=6 !acknowlege sector
parameter NAK=21 !not acknowlege sector
parameter CAN=24 !cancel transfer
parameter CRCCHAR='C' !CRC indicating character
c timeouts
parameter respnaklim=10 !seconds to allow for response to NAK
parameter naklim=10 !seconds to allow to receive first NAK
parameter eotlim=10 !seconds to wait for EOT acknowlege
parameter errlim=10 !max errors on a sector
c define an exit routine to get control on all exits to turn off
c passall and for debug cleanup
external giveup
call userex( giveup )
print *,' XMODEM Version 5.1 on VAX VMS'
c log file for debugging
open(8,file='XMODEM.LOG',carriagecontrol='LIST',status='NEW')
c assign terminal channel for QIO calls to send raw bytes.
call sys$assign('TT',chan,,)
c name work file
workf='XMODEM.WRK '
worklen=10 ! number of chars in file name
c get command line
call lib$get_foreign(line,'$_XMODEM Command: ',)
c trim blanks
do i=80,1,-1
if(line(i:i).NE.' ') goto 25
len=i
enddo
25 continue
c set to NOT delete working file
filedel=.false.
c send
sloc=index(line,'S ')
if(sloc.EQ.1) then
file=line(sloc+2:)
len=len-2
crc=.false.
print *,' Sending File: ',file(1:len)
call sendfile(file,len)
call exit
endif
c send text
sloc=index(line,'ST ')
if(sloc.EQ.1) then
file=line(sloc+3:)
len=len-3
crc=.false.
print *,' Sending Text File: ',file(1:len)
call vtoc(file,workf)
filedel=.true. !delete working file when done
call sendfile(workf,worklen)
call exit
endif
c send with CRC
sloc=index(line,'SC ')
if (sloc.EQ.1) then
file=line(sloc+3:)
len=len-3
crc=.true.
print *,' Sending File: ',file(1:len),' using CRCs'
call sendfile(file,len)
call exit
endif
c receive with checksum
sloc=index(line,'R ')
if(sloc.EQ.1) then
file=line(sloc+2:)
len=len-2
crc=.false.
print *,' Receiving File: ',file(1:len)
call recvfile(file,len)
call exit
endif
c receive text with checksum
sloc=index(line,'RT ')
if(sloc.EQ.1) then
file=line(sloc+3:)
len=len-3
crc=.false.
print *,' Receiving Text File: ',file(1:len)
call recvfile(workf,worklen)
filedel=.true. !delete working file when done
call ctov(workf,file)
call exit
endif
c receive with CRC
sloc=index(line,'RC ')
if(sloc.EQ.1) then
file=line(sloc+3:)
len=len-3
crc=.true.
print *,' Receiving File: ',file(1:len),' using CRCs'
call recvfile(file,len)
call exit
endif
c else bad command
print *,' Invalid XMODEM Command --'
print *,' Usage: XMODEM <S, ST, SC, R, RT, or RC> <file> '
print *,' S = Send, R = Receive, C = Use CRCs'
print *,' T = Convert CP/M to VAX/VMS and VAX/VMS to CP/M Text Files'
call exit
end
c----------------------------------------------------------------
c send file
subroutine sendfile(file,len)
c declare variables
include 'QIO.DCK'
character*80 file
byte sector(130), c
integer blocknumber, nakwait, stat, ic
logical ttyinlim
logical charintime, acked
logical filedel
common /filest/filedel
integer errorcount
common /err/errorcount
integer high,low
common /crcval/high,low
logical crc
integer checksum
common /checks/checksum,crc
equivalence (checksum,checksumbyte)
equivalence (ic,c)
c define ASCII characters
parameter NUL=0
parameter SOH=1
parameter EOT=4
parameter ACK=6
parameter NAK=21
parameter CAN=24
parameter CRCCHAR='C'
c timeouts
parameter respnaklim=10
parameter naklim=10
parameter eotlim=10
parameter errlim=10
open(6,name=file(1:len),iostat=stat,status='OLD')
c 1 carriagecontrol='NONE',recordtype='FIXED',recl=128)
if(stat) then
print *,'Can''t open',file(1:len),' for send.'
call exit
endif
if(crc) then
print *,' CRC Transfer Mode'
else
print *,' Checksum Transfer Mode'
endif
print *,file(1:len),' Open -- Please Run Your Receiver --'
print *
errorcount=0
blocknumber=1
nakwait=0
c await first NAK (or 'C') indicating receiver is ready
200 charintime=ttyinlim(c,1,naklim) ! return NUL if timeout
c print *,' character=',c
if( .NOT.charintime ) then
nakwait=nakwait+1
c give the turkey 80 seconds to figure out how to receive a file
if(nakwait.EQ.80) call cancel
goto 200
elseif(c.EQ.NAK) then
crc=.false.
elseif(c.EQ.CRCCHAR) then
crc=.true.
elseif(c.EQ.CAN) then
call cancel
else
c unrecognized character
nakwait=nakwait+1
if(nakwait.eq.80) call cancel
goto 200
endif
300 continue
c send new sector
read(6,1000,end=500) (sector(i),i=1,128)
1000 format(128a)
errorcount=0
c print *,' sector as read',sector
400 continue
c send sector
c print *,' SOH '
call ttyout(SOH,1)
call ttyout(blocknumber,1)
call ttyout( not(blocknumber),1 )
c print *,' blocknumber=',blocknumber
checksum=0
call clrcrc
c separate calls to slow down in case other end slow (can even introduce
c delay between characters).
c do i=1,128
c call ttyout(sector(i),1)
c enddo
call ttyout(sector,128)
c calc checksum or crc
if(crc) then
c put all bytes + two finishing zero bytes through updcrc
sector(129)=0
sector(130)=0
call updcrc( sector,130 )
call ttyout(high,1)
call ttyout(low,1)
else
do i=1,128
checksum=checksum+sector(i)
enddo
c this sends low order byte of checksum
call ttyout(checksum,1)
c print *,' checksum',checksum
endif
c sector sent, see if receiver acknowleges
c getack attempts to get ACK
c if not, repeat sector
c print*, ' should wait for ACK 10 seconds'
call getack(acked)
c print*, ' getack returned=',acked
if(.NOT.acked) goto 400
c ACK received, send next sector
blocknumber=blocknumber+1
goto 300
c end of file during read. finish up sending.
500 continue
call ttyout(EOT,1)
c getack attempts to get ACK up to errlim times
call getack(acked)
if( .NOT.acked ) goto 500
c print *,' Sending complete.'
if (filedel) then
close(6,dispose='DELETE')
else
close(6)
endif
close(8,dispose='DELETE')
return
end
c----------------------------------------------------------------
c receive file
subroutine recvfile(file,len)
c declare variables
include 'QIO.DCK'
character*80 file
byte sector(130), c, notc, checksumbyte, ck
integer blocknumber, inotc, notnotc, secbytes, stat
integer testblock, testprev, ic
logical ttyinlim
logical charintime, firstsoh
integer errorcount
common /err/errorcount
integer high,low
common /crcval/high,low
logical crc
integer checksum
common /checks/checksum,crc
equivalence (checksum,checksumbyte)
equivalence (ic,c)
c define ASCII characters
parameter NUL=0
parameter SOH=1
parameter EOT=4
parameter ACK=6
parameter NAK=21
parameter CAN=24
parameter CRCCHAR='C'
c timeouts
parameter respnaklim=10
parameter naklim=10
parameter eotlim=10
parameter errlim=10
open(7,name=file(1:len),recl=128,status='NEW',iostat=stat,
1 carriagecontrol='NONE',recordtype='FIXED')
if(stat) then
print *,' Can''t open ',file(1:len),' for recieve.'
call exit
endif
print *,' Please Send Your File --'
print *
call passall(CHAN,.TRUE.)
secbytes=129
if(crc) then
secbytes=130
endif
firstsoh=.false.
errorcount=0
blocknumber=1
c start the sender by letting ttyinlim time-out in getack routine
c so it sends a NAK or C
goto 999
800 continue
c write(8,*) ' ready for SOH'
c must allow enough time for other's disk read (xmodem50.asm allows 10 sec)
charintime=ttyinlim(c,1,respnaklim)
c if no char for a while, try NAK or C again
if( .NOT.charintime ) then
c print*,' no response to NAK or C, trying again'
write(8,*) ' no response to NAK or C, trying again'
goto 999
endif
c else received a char so see what it is
if(c.eq.NUL) goto 800 ! ignore nulls here for compatablity with old
! versions of modem7
if(c.EQ.CAN) then
print *,' Canceled. Aborting.'
write(8,*) ' Canceled. Aborting.'
call exit
endif
c write(8,*) ' EOT or SOH character=',c
if(c.NE.EOT) then
IF(c.NE.SOH) then
write(8,*) ' Not SOH, was decimal ',c
goto 999
endif
firstsoh=.true.
c character was SOH to indicate start of header
c get block number and complement
call ttyin(c,1)
c write(8,*) ' block=',c
call ttyin(notc,1)
c write(8,*) ' block complement=',notc
inotc=notc ! make integer for "not" function
notnotc=iand( not(inotc),255 ) ! mask back to byte
c c is low order byte of ic via equivalence statement
if(ic.NE.notnotc) then
write(8,*) ' block check bad.'
goto 999
endif
c block number valid but not yet checked against expected
c clear checksum and CRC
checksum=0
call clrcrc
c receive the sector and checksum bytes in one call (for speed).
c secbytes is 129 for checksum, 130 for CRC
call ttyin(sector,secbytes)
if(crc) then
c put data AND CRC bytes through updcrc
call updcrc(sector,secbytes)
c if result non-zero, BAD.
if(iand(high,255).NE.0
1 .OR.iand(low,255).NE.0) then
c write(8,*) ' CRC, high,low='
c write(8,3000) high,low
c 3000 format(2z10)
goto 999
endif
else
c don't add received checksum byte to checksum
do i=1,secbytes-1
checksum=checksum+sector(i)
enddo
ck=sector(129)
c write(8,2100) ck
c write(8,2100) checksum
c write(8,2100) checksumbyte
c 2100 format(' checksum=',z10)
if( checksumbyte.NE.ck ) then
write(8,*) ' bad checksum'
goto 999
endif
endif
c received OK so we can believe the block number, see which block it was
c mask it to be one byte
testblock=iand(blocknumber,255)
testprev=iand( blocknumber-1 ,255)
if( ic.EQ.testprev) then
write(8,*) ' prev. block again, out of synch'
c already have this block so don't write it, but ACK anyway to resynchronize
goto 985
elseif( ic.NE.testblock ) then
write(8,*) ' block number bad.'
goto 999
endif
c else was expected block
c write before acknowlege so not have to listen while write.
write(7,2000,err=900) (sector(i),i=1,128)
2000 format(128a)
goto 975
900 write(8,*) ' Can''t write sector. Aborting.'
print*, ' Can''t write sector. Aborting.'
call exit
975 continue
c recieved sector ok, wrote it ok, so acknowlege it to request next.
blocknumber=blocknumber+1
c comes here if re-received the previous sector
985 continue
errorcount=0
c write(8,*) ' ACKing, sector was ok.'
call ttyout(ACK,1)
goto 800
c else error so eat garbage in case out of synch and try again
999 continue
call eat
write(8,*) ' receive error NAK, block=',blocknumber
if(crc.AND..NOT.firstsoh) then
c keep sending 'C' 'til receive first SOH
call ttyout(CRCCHAR,1)
else
call ttyout(NAK,1)
endif
errorcount=errorcount+1
998 if(errorcount.GE.errlim) then
print*,' Unable to receive block. Aborting.'
write(8,*) ' Not receive block. Aborting.'
c delete incompletely received file
close(7,dispose='DELETE')
call exit
endif
c retry
goto 800
endif
c EOT received instead of SOH so file done.
c should keep sending ACK 'til no more EOT's ?
close(6)
close(7)
call ttyout(ACK,1)
call ttyout(ACK,1)
call ttyout(ACK,1)
c write(8,*) ' Completed.'
c print *, ' Completed.'
c transfer ok, so delete the error log file.
c close(8,status='DELETE')
close(8,dispose='DELETE')
return
end
c-------------------------------------------------------------
subroutine ctov(input,output)
c convert file of XMODEM 128 byte records with embedded <CR><LF>
c marking end-of-line and CTRL-Z marking end-of-file
c to carriage-control=LIST (normal VAX editable file)
character*80 input,output
character*300 line
character*1 CR,LF,recchar
integer blank
logical eof, eol
logical filedel
common /filest/filedel
data eof,eol/.false.,.false./
CR=char(13)
LF=char(10)
open(6,file=input,status='OLD')
c set maximum output record length to 300 (fortran default is 133)
open(7,file=output,status='NEW',carriagecontrol='LIST',recl=300)
c getchar (read new record if no input characters left)
c if EOF on input, write line and exit
c if CR then
c if getchar LF then write line
c else put back char and putchar CR into line (error if too long)
c endif
c else putchar (write error message if line too long)
c endif
c loop
100 call getc(recchar,eof,eol)
if(eof) goto 200
if(recchar.eq.CR) then
c PRINT *,' CR'
call getc(recchar,eof)
if(eof.or.recchar.ne.LF) then
call putback
len=len+1
if(len.ge.301) print *,' Out line too long.'
c print*,' too long line=',line
line(len:len)=recchar
else
c was LF
c PRINT *,' LEN=',LEN
c print*,' after LF, line=',line(1:len)
write(7,2000) line(1:len)
len=0
endif
else
c not CR, was "ordinary" character
len=len+1
if(len.ge.301) then
print *,' Out line too long.'
c PRINT *,' LINE=',LINE(1:len)
endif
line(len:len)=recchar
endif
go to 100
c flush last line and exit
200 continue
if(len.ne.0) then
write(7,2000) line(1:len)
2000 format(a)
endif
if (filedel) then
close(6,dispose='DELETE')
else
close(6)
endif
close(7)
return
end
c-------------------------------------------------------------
subroutine vtoc(input,output)
c convert VAX text file to
c file of XMODEM 128 byte records with embedded <CR><LF>
character*80 input,output
character*1 CR,LF,c
integer blank
logical eof,eol
data eof,eol/.false.,.false./
CR=char(13)
LF=char(10)
open(6,file=input,status='OLD')
open(7,file=output,status='NEW',carriagecontrol='LIST',
1 recl=128,recordtype='FIXED')
c getchar (read new line if no input characters left)
c putchar ( output record if full, close if EOF )
c if EOL on input, putchar CR putchar LF (output record if full)
c loop
100 call getv(c,eof,eol)
if(.not.eol) then
call putchar(c,eof)
if(eof) then
return
endif
else
c end of line
call putchar(CR,eof)
call putchar(LF,eof)
eol=.false.
if(eof) then
return
endif
endif
go to 100
end
c------------------------------------------
subroutine putchar(c,eof)
character*1 c
logical eof
c put character into record (write record if necessary)
c if eof, fills out rest of record with CTRL-Z's and exits
character*1 CTRLZ
character*128 record
integer point
common /reccom/point,record
data point/0/
if(eof) goto 200
point=point+1
c strip parity in case VAX file had it
record(point:point)=char(iand(ichar(c),127))
c print*,' record(point:point)=',record(point:point)
c print*,' point=',point
50 if(point.ge.128) then
c print*,' record=',record
100 write(7,1000) record
1000 format(a)
point=0
endif
return
c EOF fill record with 26's (CTRL-Z, CP/M end of file mark for ASCII)
c output last record and exit
200 continue
c print*,' in putchar EOF section'
CTRLZ=char(26)
do i=point+1,128
record(i:i)=CTRLZ
enddo
c print*,' record=',record
write(7,1000) record
close(6)
close(7)
return
end
c------------------------------------------
subroutine getc(c,eof)
c get character from a CP/M text file
character*1 c
logical eof
c point to next character in record (read record if necessary)
character*128 record
character*1 CTRLZ
integer point
logical firsttime
common /reccom/point,record,firsttime
data point/0/
data firsttime/.true./
CTRLZ=char(26)
point=point+1
if(point.gt.128.or.firsttime) then
firsttime=.false.
100 read(6,1000,end=200) record
1000 format(a)
c PRINT *,RECORD
point=1
endif
c strip parity in case CP/M file had it
c=char(iand(ichar(record(point:point)),127))
if(c.eq.CTRLZ) eof=.true.
return
200 eof=.true.
return
end
c-------------------------------------------
subroutine getv(inchar,eof,eol)
character*1 inchar
logical eof,eol
c get character from input line (read line if necessary)
c returns character and eol=.true. if no more char on line
c returns eof if end of file (no character)
character*255 line
integer len, pos
logical firsttime
common/lincom/pos,len,line
data pos/0/
if(pos.eq.0) then
read(6,1000,end=100)len,line(1:len)
1000 format(q,a)
c print*,' line=',line
endif
pos=pos+1
if(pos.gt.len) then
eol=.true.
pos=0
return
endif
c print*,' pos=',pos,' line(1:pos)=',line(1:pos)
c print*,' line(pos:pos)=',line(pos:pos)
inchar=line(pos:pos)
c print*,' pos,char',pos,inchar
return
c EOF
100 continue
eof=.true.
return
end
c----------------------------------------------
subroutine putback
c point to previous input character so this character will be getchar result
c even works if 1st char of record
integer point
logical eof
common /reccom/point
point=point-1
return
end
c-----------------------------------------------------------
subroutine clrcrc
c clears CRC
integer high,low
common /crcval/high,low
high=0
low=0
return
end
c-----------------------------------------------------------
subroutine updcrc(bbyte,n)
byte bbyte(*)
integer n
c updates the Cyclic Redundancy Code
c uses x^16 + x^12 + x^5 + 1 as recommended by CCITT
c and as used by CRCSUBS version 1.20 for 8080 microprocessor
c and incorporated into the MODEM7 protocol of the CP/M user's group
c
c during sending:
c call clrcrc
c call updcrc for each byte
c call fincrc to finish (or just put 2 extra zero bytes through updcrc)
c result to send is low byte of high and low in that order.
c
c during reception:
c call clrcrc
c call updcrc all bytes PLUS the two received CRC bytes must be passed
c to this routine
c then zero in high and low means good checksum
c
c see Computer Networks, Andrew S. Tanenbaum, Prentiss-Hall, 1981
c
c must declare integer to allow shifting
integer byte
integer high
integer low
common /crcval/high,low
integer bit,bitl,bith
c write(8,*) ' inside updcrc'
do i=1,n
c write(8,*) high,low,byte'
c write(8,1000),high,low,bbyte
1000 format(3z10)
byte=bbyte(i)
do j=1,8
c get high bits of bytes so we don't lose them when shift
c positive is left shift
bit =ishft( iand(128,byte), -7)
bitl=ishft( iand(128,low), -7)
bith=ishft( iand(128,high), -7)
c write(8,*) 'bit,bitl,bith'
c write(8,1000),bit,bitl,bith
c get ready for next iteration
newbyte=ishft(byte,1)
byte=newbyte ! introduced dummy variable newb
! to avoid "access violation"
c write(8,*) ' byte ready for next iteration'
c write(8,1000),byte
c shift those bits in
low =ishft(low ,1)+bit
high=ishft(high,1)+bitl
c write(8,*),' high,low after shifting bits in'
c write(8,1000),high,low
if(bith.eq.1) then
high=ieor(16,high)
low=ieor(33,low)
c write(8,*) ' high,low after xor'
c write(8,1000) high,low
endif
enddo
enddo
return
end
c-----------------------------------------------------------
c subroutine fincrc
c finish CRC calculation for sending result in high, low
c merely runs updcrc with two zero bytes
c integer high,low
c common /crcval/high,low
c
c byte=0
c call updcrc(byte)
c call updcrc(byte)
c return
c end
c-----------------------------------------------------------
SUBROUTINE TTYIN(LINE,N)
BYTE LINE(*)
INTEGER N
C READ CHARACTERS FROM TERMINAL
C MODIFIED BY BELONIS TO REMOVE PRIVILEGE
C MAY HAVE PROBLEM WITH TYPE-AHEAD
c should convert to time-out properly with loops in main ?
INCLUDE 'QIO.DCK'
c INCLUDE '($SSDEF)'
parameter ss$_timeout='22c'x
INTEGER I
INTEGER SYS$QIOW
INTEGER*4 terminators(2)
c logical crc
c integer checksum
c common /checks/checksum,crc
EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
DATA terminators/0,0/
C
write(8,*) ' inside ttyin, N=',N
I = SYS$QIOW(, !EVENT FLAG
- %VAL(CHAN), !CHANNEL
- %VAL(%LOC(IO$_TTYREADALL).OR.
- %LOC(IO$M_NOECHO)), ! .OR.%LOC(IO$M_TIMED)),
- STATUS,,,
- LINE, !BUFFER
- %VAL(N), !LENGTH
- , ! max time beware other disk time
- ! and Quit or Retry time
- terminators,,) !no terminators
c if(crc) then
c write(8,1000) (LINE(j),j=1,N)
c write(8,*) ' status=',STATUS
c else
c write(8,2000) (line(j),j=1,N)
c write(8,*) ' status=',status
c endif
1000 format(' ttyin=',6(20z3/),10z3)
2000 format(' ttyin=',6(20z3/),9z3)
c if(STATUS(1).EQ.SS$_TIMEOUT) THEN
c write(8,*) ' 10 second timeout in ttyin'
c print*, ' 10 second timeout in ttyin'
c call exit
c endif
IF (I) THEN
c write(8,*) ' returning from ttyin'
return
endif
C
C ERROR
write(8,*) ' ttyin error.'
CALL SYS$EXIT( %VAL(I) )
END
c-----------------------------------------------------------
subroutine eat
c eats extra characters 'til 1 second pause used to re-synch after error
byte buffer(135)
integer numchar
logical i,ttyinlim
c
parameter maxtime=1
c in case mis-interpreted header, allow at least 1 block of garbage
numchar=135
i=ttyinlim(buffer,numchar,maxtime)
c print*,' finished eating'
c write(8,*) ' finished eating'
return
end
c-----------------------------------------------------------
LOGICAL FUNCTION TTYINLIM(LINE,N,LIMIT)
BYTE LINE(*)
INTEGER N,LIMIT
C READ CHARACTERS FROM TERMINAL
C WITH TIME LIMIT, RETURN FALSE IF NO CHARACTERS
C RECEIVED FOR LIMIT SECONDS
C MODIFIED BY BELONIS TO REMOVE PRIVILEGE PROBLEM
C MAY HAVE PROBLEM WITH TYPE-AHEAD
INCLUDE 'QIO.DCK'
c INCLUDE '($SSDEF)' ! defines error status returns
parameter ss$_timeout='22c'x
INTEGER I
INTEGER SYS$QIOW
INTEGER*4 terminators(2)
EXTERNAL IO$M_NOECHO,IO$_TTYREADALL,IO$M_TIMED
DATA TERMINATORS/0,0/
C
c write(8,*) ' inside ttyinlim'
TTYINLIM=.TRUE. ! DEFAULT no delay over LIMIT seconds
I = SYS$QIOW(, !EVENT FLAG
- %VAL(CHAN), !CHANNEL
- %VAL(%LOC(IO$_TTYREADALL).OR.
- %LOC(IO$M_NOECHO).OR.%LOC(IO$M_TIMED)),
- STATUS,,,
- LINE, !BUFFER
- %VAL(N), !LENGTH
- %VAL(LIMIT), !time limit in seconds
- terminators,,) !no terminators
c print*,' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
c write(8,*) ' ttyinlim=',(LINE(j),j=1,N), ' STATUS=',STATUS
if(STATUS(1).EQ.SS$_TIMEOUT) THEN
TTYINLIM=.FALSE.
write(8,*) ' timeout'
return
ENDIF
IF (I) THEN
c write(8,*) ' returning from ttyinlim'
return
endif
C
C ERROR
write(8,*) ' ttyinlim error.'
CALL SYS$EXIT( %VAL(I) )
END
c-----------------------------------------------------------
SUBROUTINE TTYOUT(LINE,N)
BYTE LINE(*)
INTEGER*2 N
C output N characters without interpretation
INCLUDE 'QIO.DCK'
INTEGER I
INTEGER SYS$QIOW
EXTERNAL IO$M_NOFORMAT
EXTERNAL IO$_WRITEVBLK
C
IF ( N.LE.0 ) RETURN
C
c print *, ' to be sent by ttyout ', line(1)
I = SYS$QIOW(,
- %VAL(CHAN),
- %VAL(%LOC(IO$_WRITEVBLK).OR.
- %LOC(IO$M_NOFORMAT)),
- STATUS,,,
- LINE,
- %VAL(N),,
- %VAL(0),, ) !NO CARRIAGE CONTROL
if(I) then
return
endif
C
C ERROR
write(8,*) ' ttyout error.'
CALL SYS$EXIT( %VAL(I) )
END
c--------------------------------------------------
subroutine giveup
c this exit routine used especially in case exited via QIO problem
include 'qio.dck'
c note: if want log file message, must re-open since
c system already closed all files before this exit handler got control
c open(8,file='XMODEM.LOG',access='APPEND')
c write(8,*) ' Exit handler.'
c turn off passall
call passall(CHAN,.FALSE.)
return
end
c-----------------------------------------------------
SUBROUTINE PASSALL(CHAN,SWITCH)
C sets PASSALL mode for terminal connected to chanel CHAN, ON if switch true
IMPLICIT INTEGER (A-Z)
c INCLUDE '($TTDEF)'
parameter tt$m_passall=1
parameter tt$m_eightbit='8000'x
parameter io$_sensemode='27'x
parameter io$_setmode='23'x
c INCLUDE '($IODEF)'
LOGICAL SWITCH
COMMON/CHAR/CLASS,TYPE,WIDTH,CHARAC(3),LENGTH !byte reversed LENGTH
BYTE CLASS,TYPE,CHARAC,LENGTH
INTEGER*2 WIDTH,SPEED
EQUIVALENCE(CHARACTER,CHARAC)
c sense current terminal driver mode
ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SENSEMODE),,,,
1 CLASS,,,,,)
IF (.NOT.ISTAT) CALL ERROR('TERMINAL SENSEMODE',ISTAT)
IF(SWITCH) THEN
c turn on 8 bit passall
CHARACTER=CHARACTER.OR.TT$M_PASSALL.OR.
1 TT$M_EIGHTBIT
ELSE
c turn off 8 bit passall
CHARACTER=CHARACTER.AND..NOT.TT$M_PASSALL.AND.
1 .NOT.TT$M_EIGHTBIT
ENDIF
SPEED=0 !LEAVE SPEED UNCHANGED
PAR=0 !LEAVE PARITY UNCHANGED
c set terminal mode with desired passall
ISTAT=SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE),,,,
1 CLASS,,%VAL(SPEED),,%VAL(PAR),)
IF (.NOT.ISTAT) CALL ERROR('TERMINAL SETMODE',ISTAT)
RETURN
END
c---------------------------------------------------
SUBROUTINE ERROR(STRING,MSGID)
c Types error message
IMPLICIT INTEGER(A-Z)
CHARACTER*(*) STRING
CHARACTER*80 MESSAGE
TYPE *,' *** ERROR: ',STRING
write(8,*) ' *** ERROR: ',STRING
CALL SYS$GETMSG(%VAL(MSGID),MSGLEN,MESSAGE,%VAL(15),)
TYPE *,MESSAGE(1:MSGLEN),CRLF
write(8,*) MESSAGE(1:MSGLEN),CRLF
RETURN
END
c-----------------------------------------------------------
subroutine cancel
INCLUDE 'QIO.DCK'
c called to cancel send (at least)
logical charintime,ttyinlim
byte c
parameter CAN=24
parameter SPACE=32
c eat garbage
100 charintime=ttyinlim(c,1,1)
if(.NOT.charintime) goto 100
c cancel other end
call ttyout(CAN,1)
c eat garbage in case it didn't understand ?
200 charintime=ttyinlim(c,1,1)
if(.NOT.charintime) goto 200
c clear the CAN from far end's input ???? why ? xmodem50.asm does it
call ttyout(SPACE,1)
c print*,' XMODEM program canceled'
write(8,*)' XMODEM program canceled'
call exit
end
c------------------------------------------------------
subroutine getack(acked)
c returns .TRUE. if gets ACK
logical charintime, ttyinlim, acked
byte sector(130),c
integer errorcount
common /err/errorcount
parameter ACK=6
parameter errlim=10 ! max number of errors
parameter eotlim=10 ! seconds to wait for eot
c print*,' inside getack'
c empty typeahead in case garbage
c charintime=ttyinlim(sector,130,0)
c allow time for file close at other end.
charintime=ttyinlim(c,1,eotlim)
c print*,' getack got',c
if( .NOT.charintime .OR. c.NE.ACK ) then
c print*, ' not ACK, decimal=',c
write(8,*) ' not ACK, decimal=',c
errorcount=errorcount+1
if(errorcount.GE.errlim) then
write(8,*) ' not acknowleged in 10 tries.'
print*,' Can''t send sector. Aborting.'
call exit
endif
acked=.FALSE.
else
c received ACK
acked=.TRUE.
endif
return
end