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

Text File | 1990-08-05 | 19KB | 650 lines

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

unit sender;

interface

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

const
  my_version = '   Sender Unit V1.1, 13 May 89';


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-}
            last_blksize := 512;        {default as we can't determine it}
            {$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: integer;
    ch: char;
    got_attr : boolean;
    {$B AFS+}
    file_date : FA_chron;
    {$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);

    packet[0] := '#';                   { creation date attribute }
    {$B AFS+}
    packet[1] := tochar(chr(12));       { length }
    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-}
    packet[1] := tochar(chr(6));        { length }
    with this_file^.D_date do
    {$E AFS-}
      begin
        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'));
        {$B AFS+}
        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'))
        {$E AFS+}
      end;

    spack('A',n mod 64,{$B AFS+}14{$E AFS+} {$B AFS-}8{$E AFS-},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 state *)
      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 around 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 }