Columbia Kermit/kermit.zip/pub/ucsdwdme/recsw.text

Text File | 2020-01-01 | 12KB | 369 lines

(* RECEIVE SECTION *)
UCSD Pascal KERMIT for the Terak p-System, from Kate MacGregor, Cornell U

segment procedure recsw(var rec_ok: boolean);

function rdata: char;

(* send file data *)

var num, len: integer;
    ch: char;

  begin

    repeat
        if numtry > maxtry then
          begin
            debugwrite('too many intial retries in rdata');
            state := 'a';
            exit(rdata)
          end;

        num_try := num_try + 1;

        ch := rpack(len,num,recpkt);   (* receive a packet *)
        if debug and (ch<>chr(0)) then packetwrite(recpkt,len);

        refresh_screen(numtry,n);

        if (ch = 'D') then             (* got data packet *)
          begin
            if (num <> (n mod 64)) then (* wrong packet *)
              begin
                if (oldtry > maxtry) then
                  begin
                    debugwrite('too many data retries in rdata');
                    rdata := 'a';      (* too many tries, abort *)
                    exit(rdata)
                  end; (* if *)

                n := n - 1;

                if (num = (n mod 64)) then (* previous packet again *)
                  begin                (* so re-ACK it *)
                    debugint('re-acking ',num);
                    spack('Y',num,6,packet);
                    numtry := 0;       (* reset try counter *)
                                       (* stay in same state *)
                  end (* if *)
                else begin             (* wrong number *)
                    debugwrite('wrong data sequence no. in rdata');
                    state := 'a'       (* so abort *)
                    end
              end (* if *)
            else                       (* right packet *)
              begin
                bufemp(recpkt,f,len);  (* write data to file *)
                spack('Y',(n mod 64),0,packet); (* ACK packet *)
                oldtry := numtry;      (* reset try counters *)
                if numtry > 1 then
                    if istbrr then     (* clear buffer *)
                      begin
                        ch:=rcvbbt;
                        ch:='D';
                      end;
                numtry := 0;
                n := n + 1             (* bump packet number *)
                                       (* stay in data send state *)
              end (* else *)
          end (* if 'D' *)
        else if (ch = 'F') then        (* file header *)
          begin
            if (oldtry > maxtry) then
              begin
                debugwrite('too many file head tries in rdata');
                rdata := 'a';          (* too many tries, abort *)
                exit(rdata)
              end; (* if *)

            n := n - 1;

            if (num = (n mod 64)) then (* previous packet again *)
              begin                    (* so re-ACK it *)
                debugint('re-acking file header ',num);
                spack('Y',num,0,packet);
                if istbrr then begin
                  ch:=rcvbbt; (* and empty out buffer *)
                  ch:='F';
                  end;
                numtry := 0;           (* reset try counter *)
                state := state;        (* stay in same state *)
              end (* if *)
            else begin
              debugwrite('file info not previous packet in rdata');
                state := 'a'           (* not previous packet, abort *)
                end
          end (* if 'F' *)
        else if (ch = 'Z') then        (* end of file *)
          begin
            if (num <> (n mod 64)) then(* wrong packet, abort *)
              begin
                debugwrite('wrong eof packet in rdata');
                rdata := 'a';
                exit(rdata)
              end; (* if *)
            spack('Y',n mod 64,0,packet); (* ok, ACK it *)
            close(f,lock);             (* close up the file *)
            n :=  n + 1;               (* bump packet counter *)
            state := 'f';              (* go to complete state *)
          end (* else if 'Z' *)
        else if (ch = 'E') then        (* error packet *)
          begin
            error(recpkt,len);         (* display error *)
            state := 'a'               (* and abort *)
          end (* if 'E' *)
        else if (ch <> chr(0)) then begin (* some other packet type, *)
            state := 'a';                 (* abort *)
            debugwrite('wierd rdata packet');
            end
    until (state <> 'd');
    rdata := state
  end; (* rdata *)

function rfile: char;

(* receive file header *)

var num, len: integer;
    ch: char;
    oldfn: string;
    i: integer;

procedure makename(recpkt: packettype; var fn: string; l: integer);

function exist(fn: string): boolean;

(* returns true if file named fn exists *)

var f: file;

  begin
    (*$I-*) (* turn off i/o checking *)
    reset(f,fn);
    exist := (ioresult = 0)
    (*$I+*)
  end; (* exist *)

procedure checkname(var fn: string);

(* if file fn exists, makes a new name which doesn't *)
(* does this by changing letters in file name until it *)
(* finds some combination which doesn't exitst *)

var ch: char;
    i: integer;

  begin
    i := 1;
    while (i <= length(fn)) and exist(fn) do
      begin
        ch := 'A';
        while (ch in ['A'..'Z']) and exist(fn) do
          begin
            fn[i] := ch;
            ch := succ(ch);
          end; (* while *)
        i := i + 1
      end; (* while *)
    end; (* checkname *)

  begin (* makename *)
    fn := copy('               ',1,15);    (* stretch length *)
    moveleft(recpkt[0],fn[1],l);           (* get filename from packet *)
    oldfn := copy(fn, 1,l);                (* save fn sent to show user *)
    fn := copy(fn,1,min(15,l));            (* set length of filename *)
                                           (* and make sure <= 15 *)
    uppercase(fn);
    if pos('.TEXT',fn) <> length(fn)-4 then
      begin
        if length(fn) > 10 then
            fn := copy(fn,1,10);           (* can only be 15 long in all *)
        fn := concat(fn,'.TEXT');          (* and we'll add .TEXT *)
      end; (* if *)
    if fwarn then                          (* if file warning is on *)
        checkname(fn);                       (* must check that name unique *)
  end; (* makename *)

  begin (* rfile *)
    if debug then
        debugwrite('rfile');

    if (numtry > maxtry) then         (* if too many tries, give up *)
      begin
        rfile := 'a';
        exit(rfile)
      end;
    numtry := numtry + 1;

    ch := rpack(len,num,recpkt);      (* receive a packet *)
    if debug and (ch<>chr(0)) then packetwrite(recpkt,len);
    refresh_screen(numtry,n);

    if ch = 'S' then                  (* send init, maybe our ACK lost *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            debugwrite('too many tries in rfile init');
            rfile := 'a';
            exit(rfile)
          end; (* if *)

        n := n - 1;

        if num = (n mod 64) then      (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            debugint('re-acking init ',num);
            spar(packet);             (* with our send init params *)
            spack('Y',num,7,packet);
            numtry := 0;              (* reset try counter *)
            rfile := state;           (* stay in same state *)
          end (* if *)
        else                          (* not previous packet, abort *)
          state := 'a'
      end (* if 'S' *)
    else if (ch = 'Z') then           (* end of file *)
      begin
        if (oldtry > maxtry) then     (* too many tries, abort *)
          begin
            debugwrite('too many tries in filehead eof');
            rfile := 'a';
            exit(rfile)
          end; (* if *)

        n := n - 1;

        if num = (n mod 64) then       (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            debugint('re-acking eof ',num);
            spack('Y',num,0,packet);
            numtry := 0;
            rfile := state            (* stay in same state *)
          end (* if *)
        else
            rfile := 'a'              (* no, abort *)
      end (* else if *)
    else if (ch = 'F') then           (* file header *)
      begin                           (* which is what we really want *)
        if (num <> (n mod 64)) then   (* if wrong packet, abort *)
          begin
            debugwrite('wrong seq. of file header');
            rfile := 'a';
            exit(rfile)
          end;

        makename(recpkt,filename,len); (* get filename, make unique if filew *)
        gotoxy(filepos,fileline);
        write(oldfn,' ==> ',filename);

        if not getfil(filename) then  (* try to open new file *)
          begin
            ioerror(ioresult);        (* if unsuccessful, tell them *)
            rfile := 'a';             (* and abort *)
            exit(rfile)
          end; (* if *)

        spack('Y',n mod 64,0,packet); (* ACK file header *)
        oldtry := numtry;             (* reset try counters *)
        numtry := 0;
        n := n + 1;                   (* bump packet number *)
        rfile := 'd';                 (* switch to data state *)
      end (* else if *)
    else if ch = 'B' then             (* break transmission *)
      begin
        if (num <> (n mod 64)) then            (* wrong packet, abort *)
          begin
            debugwrite('wrong sequence in break packet');
            rfile := 'a';
            exit(rfile)
          end;
        spack('Y',n mod 64,0,packet); (* say ok *)
        rfile := 'c'                  (* go to complete state *)
      end (* else if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        rfile := 'a'
      end
    else if (ch = chr(0)) then        (* returned false *)
        rfile := state                (* so stay in same state *)
    else begin                        (* some weird state, so abort *)
        rfile := 'a';
        debugwrite('wierd rfile packet');
        end
  end; (* rfile *)

function rinit: char;

(* receive initialization *)

var num, len: integer;  (* packet number and length *)
    ch: char;

  begin
    if debug then
        debugwrite('rinit');

    numtry := numtry + 1;

    ch := rpack(len,num,recpkt); (* receive a packet *)
    if debug and (ch<>chr(0)) then packetwrite(recpkt,len);
    refresh_screen(num_try,n);

    if (ch = 'S') then           (* send init packet *)
      begin
        rpar(recpkt);            (* get other side's init data *)
        spar(packet);            (* fill packet with my init data *)
        ctl_set := [chr(1)..chr(31),chr(del),quote];
        spack('Y',n mod 64,7,packet); (* ACK with my params *)
        oldtry := numtry;        (* save old try count *)
        numtry := 0;             (* start a new counter *)
        n := n + 1;              (* bump packet number *)
        rinit := 'f';            (* enter file send state *)
      end (* if 'S' *)
    else if (ch = 'E') then
      begin
        rinit := 'a';
        error(recpkt,len)
      end (* if 'E' *)
    else if (ch = chr(0)) then
        rinit := 'r'             (* stay in same state *)
    else begin
        rinit := 'a';             (* abort *)
        debugwrite('wierd rinit packet');
        end
  end; (* rinit *)

(* state table switcher for receiving packets *)

  begin (* recswok *)
    writescreen('Receiving');
    state := 'r';            (* initial state is send *)
    n := 0;                  (* set packet # *)
    numtry := 0;             (* no tries yet *)

    while true do
        if state in ['d', 'f', 'r', 'c', 'a'] then
          case state of
              'd': state := rdata;
              'f': state := rfile;
              'r': state := rinit;
              'c': begin
                     rec_ok := true;
                     exit(recsw)
                   end; (* case c *)
              'a': begin
                     rec_ok := false;
                     exit(recsw)
                   end (* case a *)
            end (* case *)
        else (* state not in legal states *)
          begin
            rec_ok := false;
            exit(recsw)
          end (* else *)
  end; (* recsw *)