home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Columbia Kermit
/
kermit.zip
/
archives
/
sinclairqlb.tar.gz
/
sinclairqlb.tar
/
ql2pro.bcp
< prev
next >
Wrap
Text File
|
1988-08-16
|
19KB
|
886 lines
// This is file QL2PRO.BCP
//
// To be renamed FLP2_KERPROTO_BCPL for QDOS
SECTION "Protocol"
GET "LIBHDR"
GET "FLP2_KERHDR"
/* These routines embody the Kermit protocol as described in the manual.
The main routines were written by C.G. Selwyn using the C program in
the fifth edition of the protocol manual as a guide.
Any alterations by David Harper are made only to enable the routines
to work under QDOS, and are minimal.
*/
/*
s e n d s w
Sendsw is the state table switcher for sending
files. It loops until either it finishes, or
an error is encountered. The routines called by
sendsw are responsible for changing the state.
*/
LET sendsw() = VALOF
$(
n := 0
astate := 'S'
numtry := 0
readchar := (ser.interface=interface.qconnect -> qcon.rdch,raw.rdch)
$( SWITCHON astate INTO
$(
CASE 'D' : astate := sdata() ; ENDCASE /* Data-send state */
CASE 'F' : astate := sfile() ; ENDCASE /* File-send */
CASE 'Z' : astate := seof() ; ENDCASE /* End-Of-File */
CASE 'S' : astate := sinit() ; ENDCASE /* Send Init */
CASE 'B' : astate := sbreak(); ENDCASE /* Break-Send */
CASE 'C' : RESULTIS TRUE /* Complete */
DEFAULT : /* Unknown, fail */
CASE 'A' : erroring := TRUE
RESULTIS FALSE /* Unknown, fail */
$)
$) REPEAT
$)
/*
s i n i t
Send initiate: Send my parameters, get other side's back.
*/
AND sinit() = VALOF
$( LET num,len = ?,?
IF numtry > maxtry THEN
$( numtry := numtry + 1
RESULTIS 'A'
$)
numtry := numtry + 1
len := spar(packet)
IF remote & (\serving) THEN delay(remote.delay)
spack('S',n,len,packet)
SWITCHON rpack(@len,@num,recpkt) INTO
$( CASE 'N' :
report(FALSE)
RESULTIS astate /* Nak */
CASE 'Y' : /* Ack */
$( report(n=num)
IF n \= num RESULTIS astate
rpar(recpkt,len)
numtry := 0
n := (n+1) REM 64
fd := find.old.file(local.fname)
IF fd<=0 THEN RESULTIS 'A'
cons(writef,"Sending file %S*N",local.fname)
selectinput(fd)
RESULTIS 'F'
$)
CASE FALSE :
report(FALSE)
RESULTIS astate
DEFAULT :
RESULTIS 'A'
$)
$)
/*
s f i l e
Send File Header
*/
AND sfile() = VALOF
$( LET num,len = ?,?
LET name = VEC 20
wptr := 4
IF numtry > maxtry THEN
$( numtry := numtry + 1
RESULTIS 'A'
$)
numtry := numtry + 1
len := filnam%0
FOR i = 1 TO len DO name%(i-1) := filnam%i
spack('F',n,len,name)
SWITCHON rpack(@len,@num,recpkt) INTO
$(
CASE 'N' : /* NAK */
$( num := num = 0 -> 63,num-1
IF n \= num THEN
$( report(FALSE)
RESULTIS astate
$)
$)
CASE 'Y' :
$( report(n=num)
IF n \= num THEN RESULTIS astate
numtry := 0
n := (n+1) REM 64
size := bufill(packet)
RESULTIS 'D'
$)
CASE FALSE :
report(FALSE)
RESULTIS astate
DEFAULT :
RESULTIS 'A'
$)
$)
/*
s d a t a
Send File Data
*/
AND sdata() = VALOF
$( LET num,len = ?,?
IF numtry > maxtry THEN
$( numtry := numtry + 1
RESULTIS 'A'
$)
numtry := numtry + 1
spack('D',n,size,packet)
SWITCHON rpack(@len,@num,recpkt) INTO
$(
CASE 'N' : /* NAK */
$( num := num = 0 -> 63,num-1
IF n \= num THEN
$( report(FALSE)
RESULTIS astate
$)
$)
CASE 'Y' :
$( report(n=num)
IF n \= num THEN RESULTIS astate
numtry := 0
n := (n+1) REM 64
size := bufill(packet)
RESULTIS size = 0 ->'Z','D'
$)
CASE FALSE :
report(FALSE)
RESULTIS astate
DEFAULT :
RESULTIS 'A'
$)
$)
/*
s e o f
Send End-Of-File
*/
AND seof() = VALOF
$( LET num,len = ?,?
AND closed.file = 0
IF numtry > maxtry THEN
$( numtry := numtry + 1
RESULTIS 'A'
$)
numtry := numtry + 1
spack('Z',n,0,packet)
SWITCHON rpack(@len,@num,recpkt) INTO
$(
CASE 'N' : /* NAK */
$( num := num = 0 -> 63,num-1
IF n \= num THEN
$( report(FALSE)
RESULTIS astate
$)
$)
CASE 'Y' :
$( report(n=num)
IF n \= num THEN RESULTIS astate
numtry := 0
n := (n+1) REM 64
closed.file := close(fd)
UNLESS closed.file=0 DO
$(CF selectoutput(console)
writef("Return code %N from close*N",closed.file)
catastrophe("Failed to close file in SEOF")
$)CF
fd := 0
RESULTIS 'B'
$)
CASE FALSE :
report(FALSE)
RESULTIS astate
DEFAULT :
RESULTIS 'A'
$)
$)
/*
s b r e a k
Send Break (EOT)
*/
AND sbreak() = VALOF
$( LET num,len = ?,?
IF numtry > maxtry THEN
$( numtry := numtry + 1
RESULTIS 'A'
$)
numtry := numtry + 1
spack('B',n,0,packet)
SWITCHON rpack(@len,@num,recpkt) INTO
$(
CASE 'N' : /* NAK */
$( num := num = 0 -> 63,num-1
IF n \= num THEN
$( report(FALSE)
RESULTIS astate
$)
$)
CASE 'Y' :
$( report(n=num)
IF n \= num THEN RESULTIS astate
numtry := 0
n := (n+1) REM 64
RESULTIS 'C'
$)
CASE FALSE :
report(FALSE)
RESULTIS astate
DEFAULT :
RESULTIS 'A'
$)
$)
/*
r e c s w
This is the state table switcher for receiving files.
*/
AND recsw() = VALOF
$( TEST serving THEN
$( astate := 'F'
n := 1
$)
ELSE
$( n := 0
astate := 'R'
$)
numtry := 0
readchar := (ser.interface=interface.qconnect -> qcon.rdch,raw.rdch)
$( SWITCHON astate INTO
$(
CASE 'D' : astate := rdata() ; ENDCASE // Data receive state
CASE 'F' : astate := rfile() ; ENDCASE // File receive state
CASE 'R' : astate := rinit() ; ENDCASE // Send initiate state
CASE 'C' : RESULTIS TRUE // Complete state
CASE 'A' : erroring := TRUE
RESULTIS FALSE // Abort state
$)
$) REPEAT
$)
/*
r i n i t
Receive Initialisation
*/
AND rinit() = VALOF
$( LET len,num = ?,?
IF numtry > maxtry THEN
$( numtry := numtry + 1
RESULTIS 'A'
$)
numtry := numtry + 1
SWITCHON rpack(@len,@num,packet) INTO
$(
CASE 'S' :
$( rpar(packet,len)
len := spar(packet)
report(TRUE)
spack('Y',n,len,packet)
oldtry := numtry
numtry := 0
n := (n+1) REM 64
RESULTIS 'F'
$)
CASE FALSE :
report(FALSE)
RESULTIS astate
DEFAULT : RESULTIS 'A'
$)
$)
/*
r f i l e
Receive File Header
*/
AND rfile() = VALOF
$( LET len,num = ?,?
wptr := 0
IF numtry > maxtry THEN
$( numtry := numtry + 1
RESULTIS 'A'
$)
numtry := numtry + 1
SWITCHON rpack(@len,@num,packet) INTO
$(
CASE 'S' :
$( IF oldtry > maxtry THEN
$( oldtry := oldtry + 1
RESULTIS 'A'
$)
oldtry := oldtry + 1
TEST (num = (n=0 -> 63,n-1)) THEN
$( len := spar(packet)
report(FALSE)
spack('Y',num,len,packet)
numtry := 0
RESULTIS astate
$)
ELSE RESULTIS 'A'
$)
CASE 'Z' :
$( IF oldtry > maxtry THEN
$( oldtry := oldtry + 1
RESULTIS 'A'
$)
oldtry := oldtry + 1
TEST (num = (n=0 -> 63,n-1)) THEN
$( spack('Y',num,0,0)
report(FALSE)
numtry := 0
RESULTIS astate
$)
ELSE RESULTIS 'A'
$)
CASE 'F' : /* File Header */
$( IF (num \= n) RESULTIS 'A'
IF serving THEN
$(S // get QDOS file name from other Kermit's F packet
FOR k=0 TO len-1 DO local.fname%(k+1) := packet%k
local.fname%0 := len
$)S
fd := getfil()
IF fd<=0 THEN RESULTIS 'A'
spack('Y',num,0,0)
report(TRUE)
oldtry := numtry
numtry := 0
n := (n+1) REM 64
RESULTIS 'D'
$)
CASE 'B' : /* Break transmission */
$( IF num \= n THEN RESULTIS 'A'
spack('Y',n,0,0)
RESULTIS 'C'
$)
CASE FALSE :
report(FALSE)
RESULTIS astate
DEFAULT : RESULTIS 'A'
$)
$)
/*
r d a t a
Receive data
*/
AND rdata() = VALOF
$( LET num,len = ?,?
AND closed.file = 0
IF numtry > maxtry THEN
$( numtry := numtry + 1
RESULTIS 'A'
$)
numtry := numtry + 1
SWITCHON rpack(@len,@num,packet) INTO
$(
CASE 'D' :
$( TEST num \= n THEN
$( IF oldtry > maxtry THEN
$( oldtry := oldtry + 1
RESULTIS 'A'
$)
oldtry := oldtry + 1
IF num = (n=0 -> 63,n-1) THEN
$( spack('Y',num,6,packet)
report(FALSE)
numtry := 0
RESULTIS astate
$)
RESULTIS 'A'
$)
ELSE
$( bufemp(packet,len)
spack('Y',n,0,0)
report(TRUE)
oldtry := numtry
numtry := 0
n := (n+1) REM 64
RESULTIS 'D'
$)
$)
CASE 'F' : // Got a file header
$( IF oldtry > maxtry THEN
$( oldtry := oldtry + 1
RESULTIS 'A'
$)
oldtry := oldtry + 1
IF num = (n=0 -> 63,n-1) THEN
$( spack('Y',num,0,0)
report(FALSE)
numtry := 0
RESULTIS astate
$)
RESULTIS 'A'
$)
CASE 'Z' :
$( IF num \= n THEN RESULTIS 'A'
spack('Y',n,0,0)
report(TRUE)
IF image & (wptr \= 0) THEN writewords(@word,1)
closed.file := close(fd)
UNLESS closed.file=0 DO
$(CF selectoutput(console)
writef("Return code %N from close*N",closed.file)
catastrophe("Could not close the file in RDATA")
$)CF
fd := 0
n := (n+1) REM 64
RESULTIS 'F'
$)
CASE FALSE :
report(FALSE)
RESULTIS astate
DEFAULT : RESULTIS 'A'
$)
$)
/*
KERMIT utilities
*/
/* tochar converts a control character to a printable one by adding a space */
AND tochar(ch) = ch + '*S'
/* unchar undoes tochar */
AND unchar(ch) = ch - '*S'
/*
ctl turns a control character into a printable character by toggling the
control bit (ie. ~A -> A and A -> ~A
*/
AND ctl(ch) = ch NEQV 64
/*
s p a c k
Send a packet
*/
AND spack(type,num,len,data) BE
$( LET i = ?
LET chksum = ?
LET buffer = VEC 100/bytesperword
selectoutput(remfd)
IF s.pad>0 THEN
$(1
FOR i = 0 TO s.pad-1 DO buffer%i := s.padchar
sendchars(buffer,s.pad)
$)1
buffer%0 := s.sop
chksum := tochar(len+3)
buffer%1 := tochar(len+3)
chksum := chksum+tochar(num)
buffer%2 := tochar(num)
chksum := chksum+type
buffer%3 := type
FOR i = 4 TO 4+len-1 DO
$( LET d = data%(i-4)
buffer%i := d
chksum := chksum+d
$)
chksum := (chksum + ((chksum & #XC0) >> 6)) & #X3F
buffer%(4+len) := tochar(chksum)
buffer%(5+len) := s.eol
sendchars(buffer,6+len)
IF debug THEN
$(D
debug.report(writef,
"*N*NSent packet number %N, type %C*NData field : ",num,type)
debug.report(writebytes,data,len)
debug.report(writes,"*N*N")
$)D
$)
/*
r p a c k
Receive a packet
*/
AND rpack(len,num,data) = VALOF
$( LET i,done = ?,?
LET chksum,t,type = ?,\SOH,?
selectinput(remfd)
IF (r.timeout < mintim) THEN r.timeout := mytime
endtime := time() + r.timeout
WHILE t \= r.sop DO $(1 t := readchar()
IF t=rpack.timeout THEN
$(D1 debug.report(writes,
"*NTimed out waiting for SOH*N")
RESULTIS FALSE
$)D1
$)1
done := FALSE
WHILE (\done) DO
$( t := readchar()
IF t=rpack.timeout THEN
$(D2 debug.report(writes,"*NTimed out waiting for length byte*N")
RESULTIS FALSE
$)D2
IF \image THEN t := t & #X7F
IF t = r.sop LOOP
chksum := t
!len := unchar(t)-3
t := readchar()
IF t=rpack.timeout THEN
$(D3 debug.report(writes,"*NTimed out waiting for packet count byte*N")
RESULTIS FALSE
$)D3
IF \image THEN t := t & #X7F
IF t = r.sop LOOP
chksum := chksum+t
!num := unchar(t)
t := readchar()
IF t=rpack.timeout THEN
$(D4 debug.report(writes,"*NTimed out waiting for packet type byte*N")
RESULTIS FALSE
$)D4
IF \image THEN t := t & #X7F
IF t = r.sop LOOP
chksum := chksum+t
type := t
FOR i = 0 TO (!len)-1 DO
$( t := readchar()
IF t=rpack.timeout THEN
$(D5 debug.report(writef,
"*NTimed out after receiving %N data bytes*N",i+1)
RESULTIS FALSE
$)D5
IF \image THEN t := t & #X7F
IF t = r.sop LOOP
chksum := chksum+t
data%i := t
$)
data%(!len) := 0
t := readchar()
IF t=rpack.timeout THEN
$(D6 debug.report(writes,"*NTimed out waiting for checksum byte*N")
RESULTIS FALSE
$)D6
IF \image THEN t := t & #X7F
IF t = r.sop LOOP
done := TRUE
$)
IF debug THEN
$(D
debug.report(writef,
"*N*NReceived packet number %N, type %C*NData field : ",!num,type)
debug.report(writebytes,data,!len)
debug.report(writes,"*N*N")
$)D
chksum := (chksum + ((chksum & #XC0)>>6)) & #X3F
IF chksum \= unchar(t) THEN
$(F
debug.report(writes,"*NChecksum incorrect. Packet rejected*N")
RESULTIS FALSE
$)F
RESULTIS type
$)
/*
p u t b u f f
Put a character in the buffer
Control and 8-bit quoting are performed if required/elected
*/
AND putbuff(buffer,i,ch) = VALOF
$( LET j = 0
LET ch7 = ch & #X7F
IF quote8ing THEN // Do 8-bit quote
$( IF (ch & #X80) \= 0 THEN
$( buffer%(i+j) := quote8
j := j+1
$)
ch := ch7
$)
IF (ch7 < sp) | (ch7 = del) | // Quote control characters
(ch7 = s.quote) | // And the funnies
((ch7 = quote8) & quote8ing) THEN
$( IF \image & (ch7 = '*N') THEN
$( buffer%(i+j) := s.quote
buffer%(i+j+1) := ctl(cr)
j := j+2
$)
buffer%(i+j) := s.quote
j := j+1
IF (ch7 < sp) | (ch7 = del) THEN ch := ctl(ch)
$)
buffer%(i+j) := ch
j := j+1
RESULTIS j
$)
/*
b u f i l l
Get a bufferful of data from the file that's being sent.
*/
AND image.rdch() = VALOF
$( LET r = ?
IF wptr = 4 THEN
$( r := readwords(@word,1)
IF r = 0 THEN RESULTIS endstreamch
wptr := 0
$)
r := (@word)%wptr
wptr := wptr+1
RESULTIS r
$)
AND image.unrdch() BE wptr := wptr-1
AND bufill(buffer) = VALOF
$( LET i,j = ?,?
LET rch = image -> image.rdch,rdch
LET unrch = image -> image.unrdch,unrdch
LET t = 0
selectinput(fd)
t := rch()
i := 0
WHILE t \= endstreamch DO
$( bytes := bytes+1
j := putbuff(buffer,i,t)
IF i+j > s.packet.length-8 THEN $( unrch() ; RESULTIS i $)
i := i+j
t := rch()
$)
RESULTIS i
$)
/*
b u f e m p
Get data from an incoming packet into a file
*/
AND image.wrch(ch) BE
$( (@word)%wptr := ch
wptr := (wptr + 1) REM 4
IF wptr = 0 THEN
writewords(@word,1)
$)
AND bufemp(buffer,len) BE
$( LET t = ?
LET wch = image-> image.wrch,wrch
selectoutput(fd)
FOR i = 0 TO len-1 DO
$( LET m = 0
t := buffer%i
IF (t = quote8) & quote8ing THEN
$( m := #X80
i := i+1
t := buffer%i
$)
IF t = r.quote THEN
$( LET t7 = ?
i := i+1
t := buffer%i
t7 := t & #X7F
IF (t7 \= r.quote) &
(t7 \= quote8) THEN
t := ctl(t)
$)
IF image | (t \= '*C') THEN $( bytes := bytes+1 ; wch(t|m) $)
$)
$)
/*
g e t f i l
Open a new file
*/
AND alphanumeric(ch) = ('A' <= capitalch(ch) <= 'Z') | ('0' <= ch <= '9')
AND getfil() = find.new.file(local.fname)
AND cons(f,a1,a2,a3,a4,a5) BE IF \remote THEN
$( LET co = COS
selectoutput(console)
f(a1,a2,a3,a4,a5)
selectoutput(co)
$)
AND report(f) BE IF reporting THEN
$( TEST f THEN
$( pakcnt := (pakcnt+1) REM 5
IF pakcnt = 0 THEN
cons(writes,".")
$)
ELSE
cons(writes,"%")
$)
/*
s p a r
Fill the data area with the send-init parameters
*/
AND spar(data) = VALOF
$( data%0 := tochar(r.packet.length)
data%1 := tochar(s.timeout)
data%2 := tochar(r.pad)
data%3 := ctl(r.padchar)
data%4 := tochar(r.eol)
data%5 := s.quote
data%6 := command = w.s -> 'Y', quote8ing -> quote8,'*S'
RESULTIS 7
$)
/*
r p a r
Get the remote's send-init parameters
*/
AND rpar(data,len) BE
$( LET v = ?
s.packet.length := maxpack
s.eol := myeol
s.quote := myquote
s.pad := mypad
s.padchar := mypchar
quote8ing := FALSE
SWITCHON len INTO
$(
DEFAULT :
CASE 8:
CASE 7 : // 8-bit
SWITCHON data%6 INTO
$(
CASE 'N' : quote8ing := FALSE
ENDCASE
DEFAULT : quote8 := data%6
CASE 'Y' : quote8ing := TRUE
ENDCASE
$)
CASE 6 : // quote character
UNLESS data%5 = '*S' THEN
r.quote := data%5
CASE 5 : // eol character
UNLESS data%4 = '*S' THEN
s.eol := unchar(data%4)
CASE 4 : // pad character
UNLESS data%3 = '*S' THEN
s.padchar := ctl(data%3)
CASE 3 : // no. of pad characters
UNLESS data%2 = '*S' THEN
s.pad := unchar(data%2)
CASE 2 : // timeout
UNLESS data%1 = '*S' THEN
r.timeout := unchar(data%1)
CASE 1 : // packet length
UNLESS data%0 = '*S' THEN
s.packet.length := unchar(data%0)
CASE 0 :
$)
$)
//
AND delay(interval) BE $(0
LET time.to.end = time()
AND time.now = 0
time.to.end := time.to.end + interval
UNTIL time.now>=time.to.end DO $( time.now := time() $) REPEAT
$)0
//
AND writewords(aword,k) BE $(0
selectoutput(fd)
FOR i=0 TO 3 DO wrch(aword%i)
$)0
//
AND readwords(aword,k) = VALOF $(0
LET i,ch = 0,0
selectinput(fd)
$(1
ch := rdch()
IF ch=ENDSTREAMCH THEN BREAK
aword%i := ch
i := i + 1
$)1 REPEATUNTIL i=4
RESULTIS i
$)0