Columbia Kermit/kermit.zip/c/ucpupd.pas

Pascal/Delphi Source File | 2020-01-01 | 44KB | 1,408 lines

|x|*|f6|*|f5|*|f4|*|f3|*|f2|*|f1|{bootstrap the function keys}|.
jff/Change log:/|nsm$log|nqan|{locate & mark the Change log}|.
cfucp1.1upd[begin,end]|n|f6ucp1.1upd|n|{get specified part}|.
bsmbegin|n2fsbsmend|nqa,|{mark beginning and ending lines of this part}|.
jmend|nf/>>>>/ d|g}|!|*c|f1|f4ramdisk:|f1|n|f5|{save next part to ramdisk:}|.
|f3|f3|f3|{main extraction sequence}|.
|xsmend|njfk/|d|e|f2|{extraction initialization, replaced by filename}|.
{>>>> DIR.FIXES.TEXT}
unit dir_fixes;

{ Change log:
25 Jul 90 (RTC): added some error handling code
18 Jul 90 (RTC): Created to fix limitations of dir.info under SFS
}

interface

  type
    dTimeRec = packed record
                 min : 0..59;
                 hour : 0..24
               end {dTimeRec};

  procedure get_lastblk(dunit : integer; var filename : string;
                        var bytes : integer);

  procedure put_lastblk(dunit : integer; var filename : string;
                        bytes : integer);

  procedure get_filetime(dunit : integer; var filename : string;
                         var the_time : dTimeRec);

  procedure put_filetime(dunit : integer; var filename : string;
                         the_time : dTimeRec);

implementation

  uses
    {$U syslibr:kernel.code} kernel (directory,dirrange,dirblk,maxdir);

  function get_file(dunit : integer; var filename : string;
                    var dir : directory) : dirrange;

    var i,j : dirrange;

    begin {get_file}
      unitread(dunit,dir,sizeof(directory),dirblk);
      j := 0 {invalid entry number, in case we don't find it};
      for i := 1 to maxdir do
        if filename = dir[i].dtid
          then j := i;
      get_file := j;
      if j = 0 then
        begin
          writeln;
          writeln(chr(7),'ERROR! File "',filename,
                  '" missing from directory of unit #',dunit);
        end
    end {get_file};

  procedure put_file(dunit : integer; var dir : directory);

    begin {put_file}
      unitwrite(dunit,dir,sizeof(directory),dirblk);
    end {put_file};

  procedure get_lastblk{dunit : integer; var filename : string;
                        var bytes : integer};

    var
      disk_dir : directory;

    begin {get_lastblk}
      bytes := disk_dir[get_file(dunit,filename,disk_dir)].dlastbyte
    end {get_lastblk};

  procedure put_lastblk{dunit : integer; var filename : string;
                        bytes : integer};

    var
      item : dirrange;
      disk_dir : directory;

    begin {put_lastblk}
      item := get_file(dunit,filename,disk_dir);
      if item <> 0 then
        begin
          disk_dir[item].dlastbyte := bytes;
          put_file(dunit,disk_dir)
        end
    end {put_lastblk};

  procedure get_filetime{dunit : integer; var filename : string;
                         var the_time : dTimeRec};

    var
      disk_dir : directory;

    begin {get_filetime}
      with the_time,disk_dir[get_file(dunit,filename,disk_dir)] do
        begin
          min := dminute; hour := (dhour + 24) mod 25 {pred(dhour)}
        end;
    end {get_filetime};

  procedure put_filetime{dunit : integer; var filename : string;
                         the_time : dTimeRec};

    var
      item : dirrange;
      disk_dir : directory;

    begin {put_filetime}
      item := get_file(dunit,filename,disk_dir);
      if item <> 0 then
        with the_time,disk_dir[item] do
          begin
            dminute := min; dhour := succ(hour) mod 25;
            put_file(dunit,disk_dir)
          end
    end {put_filetime};

end. { dir.fixes }
{>>>> SENDER.TEXT}
{$D AFS-}  { indicates to compile to run without Adv. File Sys.}

unit sender;

interface

{Change log:
25 Jul 90, V1.1: Fixed invalid time attribute bug   RTC
18 Jul 90, V1.1: Fixed SFS limitations   RTC
13 May 89, V1.1: Misc. cleanups to debug messages   RTC
26 Apr 89, V1.1: minor cleanups   RTC
16 Apr 89, V1.1: Fixed "garbage in buffer" bug         RTC
13 Apr 89, V1.1: Added Version message          RTC
14 Aug 88: Fixed timeout state bug       RTC
07 Aug 88: Added conditional compilation for AFS/SFS difference    RTC
31 Jul 88: Added Attributes Packets & cancel xfr request from receiver  RTC
10 Jul 88: Converted to use screenops unit     RTC
10 Jul 88: Fixed cleareol problem on filenames      RTC
02 Jul 88: Fixed sinit 8th-bit prefix negotiation bug     RTC
30 Jun 88: Added Binary and multiple file transfers    RTC

}

   procedure sendsw(var send_ok: boolean);

   procedure sen_version;


implementation

uses
   screenops,   {RTC, 10 Jul 88}
   {$U kermglob.code} kermglob,
   {$U kermutil.code} kermutil,
   {$U kermpack.code} kermpack,
   {$B AFS+}
   {$U syslibr:attribute.code} attributes,
   {$E AFS+} {$B AFS-}
   {$U dir.fixes.code} dir_fixes,
   {$E AFS-}
   {$U syslibr:wild.code} wild,
   {$U syslibr:dir.info.code} dirinfo;

const
  my_version = '   Sender Unit V1.1, 25 Jul 90';


procedure sendsw{(var send_ok: boolean)};

var
  do_attr, still_sending, discard, next_is_empty : boolean;
  files_to_send : D_listp;
  io_status: integer;
  heap: ^integer;
  {$B AFS-}
  this_file : D_listp;
  {$E AFS-}

procedure openfile;

(* resets file of appropriate type *)

  var
    dummy : boolean;

  begin
    if debug then
        debugwrite(concat('Opening ',xfilename));
    (*$I-*) (* turn off compiler i/o checking temporarily *)
    if f_is_binary
      then
        begin
          reset(b_file,xfilename);
          if io_result = 0 then
            {$B AFS+}
            dummy := get_attribute(b_file,FA_lastvalidbyte,last_blksize);
            {$E AFS+} {$B AFS-}
            get_lastblk(files_to_send^.dunit,xfilename,last_blksize);
            {$E AFS-}
          bufend := 0                   {mark the buffer as empty!}
        end
      else reset(t_file,xfilename);
    (*$I+*) (* turn compiler i/o checking back on *)
    io_status := io_result;
    {$B AFS-}
    this_file := files_to_send;
    {$E AFS-}
  end; (* openfile *)

function sinit: char;

(* send init packet & receive other side's *)

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

  begin
    if debug then
        debugwrite('sinit');

    if numtry > maxtry then
      begin
        sinit := 'a';
        exit(sinit)
      end;

    num_try := num_try + 1;
    spar(packet);

    clear_buf(inport);

    refresh_screen(numtry,n);

    spack('S',n mod 64,10,packet);

    ch := rpack(len,num,recpkt);

    if (ch = 'N') then
      begin
        sinit := 's';
        exit(sinit)
      end (* if 'N' *)
    else if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then       (* not the right ack *)
          begin
            sinit := currstate;
            exit(sinit)
          end;
        rpar(recpkt,len);
        if (xeol = chr(0)) then   (* if they didn't spec eol *)
            xeol := chr(my_eol);    (* use mine *)
        if (quote = chr(0)) then (* if they didn't spec quote *)
            quote := my_quote;     (* use mine *)
        ctl_set := [chr(0)..chr(31),chr(del),quote];
        if en_qbin then ctl_set := ctl_set + [qbin];
        numtry := 0;
        n := n + 1;              (* increase packet number *)
        sinit := 'f';
        exit(sinit)
      end (* else if 'Y' *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sinit := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then
        sinit := currstate
    else if (ch <> 'N') then
        sinit := 'a'
  end; (* sinit *)

function sattr: char;

(* send attributes packet *)

var num, len, pkt_len: integer;
    ch: char;
    got_attr : boolean;
    {$B AFS+}
    file_date : FA_chron;
    {$E AFS+} {$B AFS-}
    file_time : dTimeRec;
    {$E AFS-}
    packet : packettype;

  begin
    if debug then
        debugwrite('sattr');

    if numtry > maxtry then
      begin
        sattr := 'a';
        exit(sattr)
      end;

    num_try := num_try + 1;

    refresh_screen(numtry,n);

    {$B AFS+}
    if f_is_binary
      then got_attr := get_attribute(b_file,FA_revision_date,file_date)
      else got_attr := get_attribute(t_file,FA_revision_date,file_date);
    with file_date,date,time do
    {$E AFS+} {$B AFS-}
    get_filetime(this_file^.dunit,xfilename,file_time);
    with this_file^.D_date,file_time do
    {$E AFS-}
      begin
        packet[0] := '#';                   { creation date attribute }

        packet[2] := chr(year div 10 + ord('0'));
        packet[3] := chr(year mod 10 + ord('0'));
        packet[4] := chr(month div 10 + ord('0'));
        packet[5] := chr(month mod 10 + ord('0'));
        packet[6] := chr(day div 10 + ord('0'));
        packet[7] := chr(day mod 10 + ord('0'));
        pkt_len := 8;
        if hour <> 24
          then {valid time}
            begin
              packet[8] := ' ';
              packet[9] := chr(hour div 10 + ord('0'));
              packet[10] := chr(hour mod 10 + ord('0'));
              packet[11] := ':';
              packet[12] := chr(min div 10 + ord('0'));
              packet[13] := chr(min mod 10 + ord('0'));
              packet[1] := tochar(chr(12));       { length }
              pkt_len := pkt_len + 6
            end
          else {invalid time}
            begin
              packet[1] := tochar(chr(6));       { length }
            end
      end;

    spack('A',n mod 64,pkt_len,packet);

    ch := rpack(len,num,recpkt);

    if (ch = 'N') then
      begin
        sattr := 'd';
        exit(sattr)
      end (* if 'N' *)
    else if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then       (* not the right ack *)
          begin
            sattr := currstate;
            exit(sattr)
          end;
        numtry := 0;
        n := n + 1;              (* increase packet number *)
        do_attr := false;
        discard := (len > 0) and (recpkt[0] = 'N');
        if discard
          then sattr := 'z'
          else sattr := 'd';
        exit(sattr)
      end (* else if 'Y' *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sattr := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then
        sattr := currstate
    else if (ch <> 'N') then
        sattr := 'a'
  end; (* sattr *)

function sdata: char;

(* send file data *)

var num, len: integer;
    ch: char;
    packarray: array[boolean] of packettype;
    sizearray: array[boolean] of integer;
    current: boolean;
    b: boolean;

function other(b: boolean): boolean;

(* complements a boolean which is used as array index *)

  begin
    if b then
        other := false
    else
        other := true
  end; (* other *)

  begin
    discard := false;
    current := true;
    packarray[current] := packet;
    sizearray[current] := size;
    next_is_empty := true;
    while (currstate = 'd') do
      begin
        if (numtry > maxtry) then             (* if too many tries, give up *)
            currstate := 'a';

        b := other(current);
        numtry := numtry + 1;

                                          (* send a data packet *)
        spack('D',n mod 64,sizearray[current],packarray[current]);

        refresh_screen(numtry,n);

        if next_is_empty then             (* set up next packet *)
          begin
            sizearray[b] := bufill(packarray[b]);
            next_is_empty := false
          end;

        ch := rpack(len,num,recpkt);      (* receive a packet *)
        if ch = 'N' then                  (* NAK, so just stay in this state *)
            if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which
*)
                sdata := currstate
            else                          (* is just like ACK for this packet *
)
              begin
                if num > 0 then
                    num := (num - 1)      (* in which case, decrement num *)
                else
                    num := 63;
                ch := 'Y';                (* and indicate an ACK *)
              end; (* else *)

        if (ch = 'Y') then
           begin
             if ((n mod 64) <> num) then (* if wrong ACK *)
               (* stay in same state *)
             else
               begin
                 numtry := 0;
                 n := n + 1;
                 current := b;
                 next_is_empty := true;
                 discard := sizearray[current] = at_badblk;
                 if read_ch(keyport, ch) then {check for user canceling send}
                   begin
                     if ord(ch) in [can_cur,can_all]
                       then discard := true;
                     if ord(ch) = can_all
                       then files_to_send := nil
                   end;
                 if len = 1 then {check for receiver canceling send}
                   begin
                     if recpkt[0] in ['X','Z']
                       then discard := true;
                     if recpkt[0] = 'Z'
                       then files_to_send := nil
                   end;
                 if (sizearray[current] = at_eof) or discard then
                     currstate := 'z'            (* set state to eof *)
                 else
                     currstate := 'd'            (* else stay in data state *)
               end {else}
           end (* if *)
          else if (ch = 'E') then
            begin
              error(recpkt,len);
              currstate := 'a'
            end (* if 'E' *)
          else if (ch = chr(0)) then      (* receive failure, so stay in d *)
          else if (ch <> 'N') then
            currstate := 'a'                  (* on anything else goto abort st
ate *)
      end; (* while *)
    size := sizearray[current];
    packet := packarray[current];
    sdata := currstate
  end; (* sdata *)

function sfile: char;

(* send file header *)

var num, len, i: integer;
    ch: char;
    fn: packettype;
    oldfn: string255;

procedure legalize(var fn: string255);

(* make sure we send only 1 '.' in filename *)

var count, i, j, l: integer;

  begin
    if not lit_names then
      begin
        count := 0;
        l := length(fn);
        for i := 1 to l do                                  (* count '.'s in fn
 *)
            if fn[i] = '.' then
                count := count + 1;
        for i := 1 to count-1 do                            (* remove all but 1
 *)
          begin
            j := 1;
            while (j < l) and (fn[j] <> '.') do
                j := j + 1;                                 (* by finding it *)
            fn := concat(copy(fn,1,j-1),copy(fn,j+1,l-j));  (* and copying arou
nd it *)
            l := l - 1
          end (* for i *)
      end;
    i := pos(':',fn);
    if i <> 0 then
      fn := copy(fn,i+1,length(fn)-i)         {remove Vol. name}
  end; (* legalize *)

  begin
    if debug then
        debugwrite('sfile');

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

    oldfn := xfilename;
    legalize(xfilename);                (* make filename acceptable to remote *
)
    len := length(xfilename);

    moveleft(xfilename[1],fn[0],len);   (* move filename into a packettype *)

    SC_erase_to_EOL(filepos,fileline);
    write(oldfn,' ==> ',xfilename);

    refresh_screen(numtry,n);

    spack('F',n mod 64,len,fn);               (* send file header packet *)

    if next_is_empty then
      begin
        size := bufill(packet);            (* get first data from file *)
        next_is_empty := false
      end;                             (* while waiting for response *)

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
          begin
            sfile := 'f';
            exit(sfile)                (* is just like ACK for this packet *)
          end
        else
          begin
            if (num > 0) then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then  (* if wrong ACK, stay in F state *)
          begin
            sfile := 'f';
            exit(sfile)
          end;
        numtry := 0;
        n := n + 1;
        do_attr := en_attr;
        sfile := 'd';
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sfile := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then  {stay in f state}
        sfile := 'f'
    else if (ch <> 'N') then (* don't recognize it *)
        sfile := 'a'
  end; (* sfile *)

function seof: char;

(* send end of file *)

var num, len: integer;
    ch: char;

  begin
    if debug then
        debugwrite('seof');

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

    refresh_screen(numtry,n);

    packet[0] := 'D';           {set up in case of discard}

    spack('Z',(n mod 64),ord(discard),packet);    (* send end of file packet *)

    if debug then
        debugwrite('seof1');

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
          begin
            seof := 'z';
            exit(seof)                 (* is just like ACK for this packet *)
          end
        else
          begin
            if num > 0 then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if debug then
            debugwrite('seof2');
        if ((n mod 64) <> num) then     (* if wrong ACK, stay in Z state *)
          begin
            seof := 'z';
            exit(seof)
          end;
        numtry := 0;
        n := n + 1;
        if debug then
            debugwrite(concat('Closing ',xfilename));
        if f_is_binary
          then close(b_file)
          else close(t_file);
        while files_to_send <> nil do with files_to_send^ do
          begin
            xfilename := concat(D_volume,':',D_title);
            seof := 'f';
            next_is_empty := true;

            openfile;
            files_to_send := D_next_entry;
            if io_status <> 0
              then io_error(io_status)
              else exit(seof)
          end {while};
        seof := 'b'
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        seof := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then         (* receive failed, so stay in z state *)
        seof := 'z'
    else if (ch <> 'N') then           (* other error, just abort *)
        seof := 'a'
  end; (* seof *)

function sbreak: char;

var num, len: integer;
    ch: char;

(* send break (end of transmission) *)

  begin
    if debug then
        debugwrite('sbreak');

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

    refresh_screen(numtry,n);

    spack('B',(n mod 64),0,packet);    (* send Break Transfer packet *)

    ch := rpack(len,num,recpkt);
    if ch = 'N' then                   (* NAK, so just stay in this state *)
        if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
          begin
            sbreak := 'b';
            exit(sbreak)               (* is just like ACK for this packet *)
          end
        else
          begin
            if num > 0 then
                num := (num - 1)       (* in which case, decrement num *)
            else
                num := 63;
            ch := 'Y';                 (* and indicate an ACK *)
          end; (* else *)

    if (ch = 'Y') then
      begin
        if ((n mod 64) <> num) then    (* if wrong ACK, stay in B state *)
          begin
            sbreak := 'b';
            exit(sbreak)
          end;
        numtry := 0;
        n := n + 1;
        sbreak := 'c'                  (* else, switch state to complete *)
      end (* if *)
    else if (ch = 'E') then
      begin
        error(recpkt,len);
        sbreak := 'a'
      end (* if 'E' *)
    else if (ch = chr(0)) then         (* receive failed, so stay in b state *)
        sbreak := 'b'
    else if (ch <> 'N') then           (* other error, just abort *)
        sbreak := 'a'
  end; (* sbreak *)

(* state table switcher for sending *)

  begin (* sendsw *)
    mark(heap);
    send_ok := false;
    still_sending :=
        D_dirlist(xfilename,[D_code..D_svol],files_to_send,false) = D_okay;
    if files_to_send <> nil then with files_to_send^ do
      begin
        xfilename := concat(D_volume,':',D_title);
        next_is_empty := true;

        openfile;
        files_to_send := D_next_entry;
        if io_status <> 0 then
          begin
            io_error(io_status);
            still_sending := false
          end
      end;

    if still_sending then write_screen('Sending');
    currstate := 's';
    n := 0;       (* set packet # *)
    numtry := 0;
    flush_comm;         {flush any garbage in buffer}

    while still_sending do
        if currstate in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then
          case currstate of
              'd': if do_attr
                     then currstate := sattr
                     else currstate := sdata;
              'f': currstate := sfile;
              'z': currstate := seof;
              's': currstate := sinit;
              'b': currstate := sbreak;
              'c': begin
                     send_ok := true;
                     still_sending := false
                   end; (* case c *)
              'a': still_sending := false
            end (* case *)
        else (* state not in legal states *)
          begin
            debugwrite('Unknown State');
            still_sending := false
          end (* else *);
    release(heap)
  end; (* sendsw *)

procedure sen_version;

  begin
    writeln(my_version)
  end {sen_version};

end. { sender }
{>>>> RECEIVER.TEXT}
{$D AFS-}       {indicates for compile to run without Adv. File Sys.}

unit receiver;

interface

{Change log:
18 Jul 90, V1.1: Fixed SFS limitations   RTC
18 May 89, V1.1: Added debugdate to reread file dates (fixed date bug[??]) RTC
13 May 89, V1.1: Misc. cleanup to debug messages   RTC
30 Apr 89, V1.1: Fixed receiver won't stop on maxtry bug   RTC
26 Apr 89, V1.1: minor cleanups   RTC
16 Apr 89, V1.1: Fixed "garbage in buffer" bug       RTC
16 Apr 89, V1.1: Fixed "short text filename" bug.   RTC
15 Apr 89, V1.1: Added GET protocol & debug logging of date set result    RTC
13 Apr 89, V1.1: Added version message          RTC
17 Aug 88: Fixed garbage after partial last block of bin. file    RTC
07 Aug 88: Added conditional compilation for AFS/SFS differences   RTC
31 Jul 88: Added Attribute Packets & user discard requests to sender   RTC
10 Jul 88: Converted to use screenops unit     RTC
10 Jul 88: Fixed cleareol problem on filenames     RTC
02 Jul 88: Added binary file transfer & discard protocol   RTC

}

  procedure recsw(var rec_ok: boolean; get_from_server : boolean);

  procedure rec_version;


implementation

uses
   screenops,   {RTC, 10 Jul 88}
   {$U kermglob.code} kermglob,
   {$U kermutil.code} kermutil,
   {$U kermpack.code} kermpack,
   {$B AFS+}
   {$U syslibr:attribute.code} attributes;
   {$E AFS+} {$B AFS-}
   {$U dir.fixes.code} dir_fixes,
   {$U syslibr:wild.code} wild,
   {$U syslibr:dir.info.code} dirinfo;
   {$E AFS-}

const
  my_version = '   Receiver Unit V1.1, 18 Jul 90';

{$B AFS-}
procedure debugdate;

  var
    heap : ^integer;
    list : D_listp;
    rslt : D_result;

  begin {debugdate}
    mark(heap);
    rslt := D_dirlist(xfilename,[Dvol..Ddir],list,false);
    if rslt <> D_okay then debugwrite('Can''t Access File Date');
    if debug then with list^,D_date do
      begin
        debugwrite('');
        write(debf,'File ',D_volume,':',D_title,' Current Date = ',
              month,'/',day,'/',year)
      end;
    release(heap)
  end {debugdate};
{$E AFS-}

procedure recsw{(var rec_ok: boolean; get_from_server : boolean)};

var
  date_attr : record
                valid : boolean;
                value : {$B AFS+} FA_chron {$E AFS+}
                        {$B AFS-}
                        record
                          date : D_daterec;
                          time : D_timerec
                        end;
                        {$E AFS-}
              end;

function bufattr(buffer : packettype; len : integer) : integer;

  var
    sp_pos,i,j,buffered : integer;
    tempattr : string;

  begin {bufattr}
    packet[0] := 'Y'; buffered := 1;    {agree to accept file}
    i := 0; while i < len do
      begin
        if buffer[i] in ['#'] then      {acceptable attribute}
          begin
            tempattr := '';
            for j := 1 to ord(unchar(buffer[succ(i)])) do
              begin
                tempattr := concat(tempattr,' ');
                tempattr[length(tempattr)] := buffer[succ(i) + j]
              end;
            case buffer[i] of
              '#' : with date_attr,value,date,time do
                begin
                  sp_pos := pos(' ',tempattr);
                  if sp_pos = 0 then sp_pos := succ(length(tempattr));
                  year := (ord(tempattr[sp_pos-6]) - ord('0')) * 10
                        + (ord(tempattr[sp_pos-5]) - ord('0'));
                  month := (ord(tempattr[sp_pos-4]) - ord('0')) * 10
                         + (ord(tempattr[sp_pos-3]) - ord('0'));
                  day := (ord(tempattr[sp_pos-2]) - ord('0')) * 10
                       + (ord(tempattr[sp_pos-1]) - ord('0'));
                  if length(tempattr) > sp_pos then
                    begin
                      hour := (ord(tempattr[sp_pos+1]) - ord('0')) * 10
                            + (ord(tempattr[sp_pos+2]) - ord('0'));
                      min := (ord(tempattr[sp_pos+4]) - ord('0')) * 10
                            + (ord(tempattr[sp_pos+5]) - ord('0'))
                    end
                  else          {no time provided}
                    begin
                      hour := 24 {non-valid time}; min := 0
                    end;
                  valid := true
                end
            end {case}
          end
        else                            {reject attribute}
          begin
            packet[buffered] := buffer[i];
            buffered := succ(buffered)
          end;
        i := succ(succ(i) + ord(unchar(buffer[succ(i)])))
      end;
    bufattr := buffered
  end {bufattr};

function rdata: char;

(* receive file data *)

var dummy, num, len: integer;
    ch: char;
    {$B AFS+}
    did_attr : boolean;
    {$E AFS+} {$B AFS-}
    heap : ^integer;
    this_file : D_listp;
    {$E AFS-}
    i: integer;

  begin

    repeat
        debugwrite('rdata');

        if numtry > maxtry then
          begin
            currstate := 'a';
            exit(rdata)
          end;
        num_try := num_try + 1;

        ch := rpack(len,num,recpkt);   (* receive a packet *)

        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
                    rdata := 'a';      (* too many tries, abort *)
                    exit(rdata)
                  end; (* if *)

                if (num = (pred(n) mod 64)) then (* previous packet again *)
                  begin                (* so re-ACK it *)
                    spack('Y',num,0,packet);
                    numtry := 0;       (* reset try counter *)
                                       (* stay in same state *)
                  end (* if *)
                else                   (* wrong number *)
                    currstate := 'a'       (* so abort *)
              end (* if *)
            else                       (* right packet *)
              begin
                bufemp(recpkt,len);  (* write data to file *)
                if read_ch(keyport, ch) then {check if user wants to can}
                  packet[0] := ctl(ch);
                spack('Y',(n mod 64),ord(ord(ch) in [can_cur,can_all]),
                      packet); (* ACK packet *)
                oldtry := numtry;      (* reset try counters *)
                numtry := 0;
                n := n + 1             (* bump packet number *)
                                       (* stay in data receive state *)
              end (* else *)
          end (* if 'D' *)
        else if ch = 'A' then           { Attributes }
          begin
            if (num <> (n mod 64)) then (* wrong packet *)
              begin
                if (oldtry > maxtry) then
                  begin
                    rdata := 'a';      (* too many tries, abort *)
                    exit(rdata)
                  end; (* if *)

                if (num = (pred(n) mod 64)) then (* previous packet again *)
                  begin                (* so re-ACK it *)
                    spack('Y',num,0,packet);
                    numtry := 0;       (* reset try counter *)
                                       (* stay in same state *)
                  end (* if *)
                else                   (* wrong number *)
                    currstate := 'a'       (* so abort *)
              end (* if *)
            else                       (* right packet *)
              begin
                spack('Y',(n mod 64),bufattr(recpkt,len),packet); (* ACK packet
 *)
                oldtry := numtry;      (* reset try counters *)
                numtry := 0;
                n := n + 1             (* bump packet number *)
                                       (* stay in data receive state *)
              end (* else *)
          end {if 'A'}
        else if (ch = 'F') then        (* file header *)
          begin
            if (oldtry > maxtry) then
              begin
                rdata := 'a';          (* too many tries, abort *)
                exit(rdata)
              end; (* if *)

            if (num = (pred(n) mod 64)) then (* previous packet again *)
              begin                    (* so re-ACK it *)
                spack('Y',num,0,packet);
                numtry := 0;           (* reset try counter *)
                                               (* stay in same state *)
              end (* if *)
            else
                currstate := 'a'           (* not previous packet, abort *)
          end (* if 'F' *)
        else if (ch = 'Z') then        (* end of file *)
          begin
            if (num <> (n mod 64)) then(* wrong packet, abort *)
              begin
                rdata := 'a';
                exit(rdata)
              end; (* if *)
            spack('Y',n mod 64,0,packet); (* ok, ACK it *)
            if (len = 1) and (recpkt[0] = 'D')
              then
                begin
                  debugwrite(concat('Discarding ',xfilename));
                  if f_is_binary               {discard the file}
                    then close(b_file)
                    else close(t_file)
                end
              else
                begin
                  debugwrite(concat('Closing ',xfilename));
                  if f_is_binary               (* close up the file *)
                    then
                      begin
                        if bufpos > 1               {data in last block}
                          then
                            begin
                              for dummy := bufpos to blksize do
                                filebuf[dummy] := chr(0);
                              dummy := blockwrite(b_file,filebuf,1);
                              {$B AFS+}
                              dummy := pred(bufpos);
                              did_attr :=
                                  put_attribute(b_file,FA_lastvalidbyte,dummy)
                              {$E AFS+}
                            end;
                        {$B AFS+}
                        with date_attr do if valid then {set date}
                          did_attr :=
                              put_attribute(b_file,FA_revisiondate,value);
                        {$E AFS+}
                        close(b_file,lock)
                      end
                    else
                      begin
                        {$B AFS+}
                        with date_attr do if valid then {set date}
                          did_attr :=
                              put_attribute(t_file,FA_creationdate,value);
                        {$E AFS+}
                        close(t_file,lock)
                      end;
                  {$B AFS-}
                  mark(heap);
                  if D_dirlist(xfilename,[D_code,D_text,D_data,D_svol],
                               this_file,false) <> D_okay
                    then {we have an error... should never occur}
                      begin
                        this_file := nil;
                        debugwrite('Can''t locate Unit containing File')
                      end
                    else if f_is_binary and (bufpos > 1) then
                      put_lastbyte(this_file^.dunit,xfilename,pred(bufpos));
                  debugdate;
                  with date_attr do if valid then {set date,time}
                    begin
                      case D_changedate(xfilename,value.date,
                           [D_code,D_text,D_data,D_svol]) of
                        D_okay :      debugwrite('Date set OK');
                        D_notfound :  debugwrite('No such File, Date not set');
                        D_nameerror : debugwrite('Name error, Date not set');
                        D_offline :   debugwrite('Volume offline, Date not set'
);
                        D_other :     debugwrite('Unknown error, Date not set')
;
                      end {case};
                      if this_file <> nil
                        then put_filetime(this_file^.dunit,xfilename,value.time
)
                    end;
                  debugdate;
                  release(heap);
                  {$E AFS-}
                end;
            bufpos := 1;                {clean up binary file buffer}
            n :=  n + 1;               (* bump packet counter *)
            currstate := 'f';              (* go to complete state *)
          end (* else if 'Z' *)
        else if (ch = 'E') then        (* error packet *)
          begin
            error(recpkt,len);         (* display error *)
            currstate := 'a'               (* and abort *)
          end (* if 'E' *)
        else if (ch <> chr(0)) then    (* some other packet type, *)
            currstate := 'a'               (* abort *)
    until (currstate <> 'd');
    rdata := currstate
  end; (* rdata *)

function rfile: char;

(* receive file header *)

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

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

function exist(fn: string255): 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: string255);

(* 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 := succ(fn[i]);    {RTC, 13 May 89}
        if not (ch in ['A'..'Z']) then 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 not f_is_binary then
        if (pos('.TEXT',fn) <> length(fn)-4) or (length(fn) < 5) 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 *)
    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 *)

    refresh_screen(numtry,n);

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

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

        if num = (pred(n) mod 64) then       (* previous packet mod 64? *)
          begin                       (* yes, ACK it again *)
            spack('Y',num,0,packet);
            numtry := 0;
            rfile := currstate            (* 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
            rfile := 'a';
            exit(rfile)
          end;

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

        if not getfil(xfilename) 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 *)

        {initializations for file attribute data}
        date_attr.valid := false;
        {end of initializations for file attribute data}

        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
            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 := currstate                (* so stay in same state *)
    else                              (* some weird state, so abort *)
        rfile := 'a'
  end; (* rfile *)

function rinit: char;

(* receive initialization *)

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

  begin
    debugwrite('rinit');

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

    if get_from_server then {ask server for files}
      begin
        len := length(xfilename);
        moveleft(xfilename[1],fn[0],len);
        spack('R', n mod 64, len, fn)
      end;

    ch := rpack(len,num,recpkt); (* receive a packet *)
    refresh_screen(num_try,n);

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

(* state table switcher for receiving packets *)

  begin (* recswok *)
    rec_ok := false;
    writescreen('Receiving');
    currstate := 'r';            (* initial state is receive *)
    n := 0;                  (* set packet # *)
    numtry := 0;             (* no tries yet *)
    flush_comm;         {flush any garbage in buffer}

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

procedure rec_version;

  begin
    writeln(my_version)
  end {rec_version};

end. { receiver }
{>>>>}