Columbia Kermit/kermit.zip/archives/sinclairqlb.zip/ql2pro.bcp

Text File | 1988-08-16 | 20KB | 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