Columbia Kermit/kermit.zip/archives/ucsdpecan.zip/receiver.text

Text File | 1990-08-05 | 21KB | 581 lines

$D AFS-}       {indicates for compile to run without Adv. File Sys.

unit receiver;

interface

{Change log:
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 syslibr:wild.code} wild,
   {$U syslibr:dir.info.code} dirinfo;
   {$E AFS-}

const
  my_version = '   Receiver Unit V1.1, 18 May 89';

$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-} D_daterec {$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 {$B AFS+},date,time{$E AFS+} 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'));
                  {$B AFS+}
                  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;
                  {$E AFS+}
                  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+}
    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);
                              dummy := pred(bufpos);
                              {$B AFS+}
                              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-}
                  debugdate;
                  with date_attr do if valid then {set date}
                    case D_changedate(xfilename,value,
                         [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};
                  debugdate;
                  {$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 }