home *** CD-ROM | disk | FTP | other *** search
/ kermit.columbia.edu / kermit.columbia.edu.tar / kermit.columbia.edu / archives / ucsdpecan.tar.gz / ucsdpecan.tar / sender.text < prev    next >
Text File  |  1990-08-05  |  18KB  |  650 lines
  1. $D AFS-}  { indicates to compile to run without Adv. File Sys.
  2.  
  3. unit sender;
  4.  
  5. interface
  6.  
  7. {Change log:
  8. 13 May 89, V1.1: Misc. cleanups to debug messages   RTC
  9. 26 Apr 89, V1.1: minor cleanups   RTC
  10. 16 Apr 89, V1.1: Fixed "garbage in buffer" bug         RTC
  11. 13 Apr 89, V1.1: Added Version message          RTC
  12. 14 Aug 88: Fixed timeout state bug       RTC
  13. 07 Aug 88: Added conditional compilation for AFS/SFS difference    RTC
  14. 31 Jul 88: Added Attributes Packets & cancel xfr request from receiver  RTC
  15. 10 Jul 88: Converted to use screenops unit     RTC
  16. 10 Jul 88: Fixed cleareol problem on filenames      RTC
  17. 02 Jul 88: Fixed sinit 8th-bit prefix negotiation bug     RTC
  18. 30 Jun 88: Added Binary and multiple file transfers    RTC
  19.  
  20. }
  21.  
  22.    procedure sendsw(var send_ok: boolean);
  23.  
  24.    procedure sen_version;
  25.  
  26.  
  27. implementation
  28.  
  29. uses
  30.    screenops,   {RTC, 10 Jul 88}
  31.    {$U kermglob.code} kermglob,
  32.    {$U kermutil.code} kermutil,
  33.    {$U kermpack.code} kermpack,
  34.    {$B AFS+} {$U syslibr:attribute.code} attributes, {$E AFS+}
  35.    {$U syslibr:wild.code} wild,
  36.    {$U syslibr:dir.info.code} dirinfo;
  37.  
  38. const
  39.   my_version = '   Sender Unit V1.1, 13 May 89';
  40.  
  41.  
  42. procedure sendsw{(var send_ok: boolean)};
  43.  
  44. var
  45.   do_attr, still_sending, discard, next_is_empty : boolean;
  46.   files_to_send : D_listp;
  47.   io_status: integer;
  48.   heap: ^integer;
  49.   {$B AFS-}
  50.   this_file : D_listp;
  51.   {$E AFS-}
  52.  
  53. procedure openfile;
  54.  
  55. (* resets file of appropriate type *)
  56.  
  57.   var
  58.     dummy : boolean;
  59.  
  60.   begin
  61.     if debug then
  62.         debugwrite(concat('Opening ',xfilename));
  63.     (*$I-*) (* turn off compiler i/o checking temporarily *)
  64.     if f_is_binary
  65.       then
  66.         begin
  67.           reset(b_file,xfilename);
  68.           if io_result = 0 then
  69.             {$B AFS+}
  70.             dummy := get_attribute(b_file,FA_lastvalidbyte,last_blksize);
  71.             {$E AFS+} {$B AFS-}
  72.             last_blksize := 512;        {default as we can't determine it}
  73.             {$E AFS-}
  74.           bufend := 0                   {mark the buffer as empty!}
  75.         end
  76.       else reset(t_file,xfilename);
  77.     (*$I+*) (* turn compiler i/o checking back on *)
  78.     io_status := io_result;
  79.     {$B AFS-}
  80.     this_file := files_to_send;
  81.     {$E AFS-}
  82.   end; (* openfile *)
  83.  
  84. function sinit: char;
  85.  
  86. (* send init packet & receive other side's *)
  87.  
  88. var num, len, i: integer;  (* packet number and length *)
  89.     ch: char;
  90.  
  91.   begin
  92.     if debug then
  93.         debugwrite('sinit');
  94.  
  95.     if numtry > maxtry then
  96.       begin
  97.         sinit := 'a';
  98.         exit(sinit)
  99.       end;
  100.  
  101.     num_try := num_try + 1;
  102.     spar(packet);
  103.  
  104.     clear_buf(inport);
  105.  
  106.     refresh_screen(numtry,n);
  107.  
  108.     spack('S',n mod 64,10,packet);
  109.  
  110.     ch := rpack(len,num,recpkt);
  111.  
  112.     if (ch = 'N') then
  113.       begin
  114.         sinit := 's';
  115.         exit(sinit)
  116.       end (* if 'N' *)
  117.     else if (ch = 'Y') then
  118.       begin
  119.         if ((n mod 64) <> num) then       (* not the right ack *)
  120.           begin
  121.             sinit := currstate;
  122.             exit(sinit)
  123.           end;
  124.         rpar(recpkt,len);
  125.         if (xeol = chr(0)) then   (* if they didn't spec eol *)
  126.             xeol := chr(my_eol);    (* use mine *)
  127.         if (quote = chr(0)) then (* if they didn't spec quote *)
  128.             quote := my_quote;     (* use mine *)
  129.         ctl_set := [chr(0)..chr(31),chr(del),quote];
  130.         if en_qbin then ctl_set := ctl_set + [qbin];
  131.         numtry := 0;
  132.         n := n + 1;              (* increase packet number *)
  133.         sinit := 'f';
  134.         exit(sinit)
  135.       end (* else if 'Y' *)
  136.     else if (ch = 'E') then
  137.       begin
  138.         error(recpkt,len);
  139.         sinit := 'a'
  140.       end (* if 'E' *)
  141.     else if (ch = chr(0)) then
  142.         sinit := currstate
  143.     else if (ch <> 'N') then
  144.         sinit := 'a'
  145.   end; (* sinit *)
  146.  
  147. function sattr: char;
  148.  
  149. (* send attributes packet *)
  150.  
  151. var num, len: integer;
  152.     ch: char;
  153.     got_attr : boolean;
  154.     {$B AFS+}
  155.     file_date : FA_chron;
  156.     {$E AFS+}
  157.     packet : packettype;
  158.  
  159.   begin
  160.     if debug then
  161.         debugwrite('sattr');
  162.  
  163.     if numtry > maxtry then
  164.       begin
  165.         sattr := 'a';
  166.         exit(sattr)
  167.       end;
  168.  
  169.     num_try := num_try + 1;
  170.  
  171.     refresh_screen(numtry,n);
  172.  
  173.     packet[0] := '#';                   { creation date attribute }
  174.     {$B AFS+}
  175.     packet[1] := tochar(chr(12));       { length }
  176.     if f_is_binary
  177.       then got_attr := get_attribute(b_file,FA_revision_date,file_date)
  178.       else got_attr := get_attribute(t_file,FA_revision_date,file_date);
  179.     with file_date,date,time do
  180.     {$E AFS+} {$B AFS-}
  181.     packet[1] := tochar(chr(6));        { length }
  182.     with this_file^.D_date do
  183.     {$E AFS-}
  184.       begin
  185.         packet[2] := chr(year div 10 + ord('0'));
  186.         packet[3] := chr(year mod 10 + ord('0'));
  187.         packet[4] := chr(month div 10 + ord('0'));
  188.         packet[5] := chr(month mod 10 + ord('0'));
  189.         packet[6] := chr(day div 10 + ord('0'));
  190.         packet[7] := chr(day mod 10 + ord('0'));
  191.         {$B AFS+}
  192.         packet[8] := ' ';
  193.         packet[9] := chr(hour div 10 + ord('0'));
  194.         packet[10] := chr(hour mod 10 + ord('0'));
  195.         packet[11] := ':';
  196.         packet[12] := chr(min div 10 + ord('0'));
  197.         packet[13] := chr(min mod 10 + ord('0'))
  198.         {$E AFS+}
  199.       end;
  200.  
  201.     spack('A',n mod 64,{$B AFS+}14{$E AFS+} {$B AFS-}8{$E AFS-},packet);
  202.  
  203.     ch := rpack(len,num,recpkt);
  204.  
  205.     if (ch = 'N') then
  206.       begin
  207.         sattr := 'd';
  208.         exit(sattr)
  209.       end (* if 'N' *)
  210.     else if (ch = 'Y') then
  211.       begin
  212.         if ((n mod 64) <> num) then       (* not the right ack *)
  213.           begin
  214.             sattr := currstate;
  215.             exit(sattr)
  216.           end;
  217.         numtry := 0;
  218.         n := n + 1;              (* increase packet number *)
  219.         do_attr := false;
  220.         discard := (len > 0) and (recpkt[0] = 'N');
  221.         if discard
  222.           then sattr := 'z'
  223.           else sattr := 'd';
  224.         exit(sattr)
  225.       end (* else if 'Y' *)
  226.     else if (ch = 'E') then
  227.       begin
  228.         error(recpkt,len);
  229.         sattr := 'a'
  230.       end (* if 'E' *)
  231.     else if (ch = chr(0)) then
  232.         sattr := currstate
  233.     else if (ch <> 'N') then
  234.         sattr := 'a'
  235.   end; (* sattr *)
  236.  
  237. function sdata: char;
  238.  
  239. (* send file data *)
  240.  
  241. var num, len: integer;
  242.     ch: char;
  243.     packarray: array[boolean] of packettype;
  244.     sizearray: array[boolean] of integer;
  245.     current: boolean;
  246.     b: boolean;
  247.  
  248. function other(b: boolean): boolean;
  249.  
  250. (* complements a boolean which is used as array index *)
  251.  
  252.   begin
  253.     if b then
  254.         other := false
  255.     else
  256.         other := true
  257.   end; (* other *)
  258.  
  259.   begin
  260.     discard := false;
  261.     current := true;
  262.     packarray[current] := packet;
  263.     sizearray[current] := size;
  264.     next_is_empty := true;
  265.     while (currstate = 'd') do
  266.       begin
  267.         if (numtry > maxtry) then             (* if too many tries, give up *)
  268.             currstate := 'a';
  269.  
  270.         b := other(current);
  271.         numtry := numtry + 1;
  272.  
  273.                                           (* send a data packet *)
  274.         spack('D',n mod 64,sizearray[current],packarray[current]);
  275.  
  276.         refresh_screen(numtry,n);
  277.  
  278.         if next_is_empty then             (* set up next packet *)
  279.           begin
  280.             sizearray[b] := bufill(packarray[b]);
  281.             next_is_empty := false
  282.           end;
  283.  
  284.         ch := rpack(len,num,recpkt);      (* receive a packet *)
  285.         if ch = 'N' then                  (* NAK, so just stay in this state *)
  286.             if ((n+1) mod 64 <> num) then (* unless NAK for next packet, which *)
  287.                 sdata := currstate
  288.             else                          (* is just like ACK for this packet *)
  289.               begin
  290.                 if num > 0 then
  291.                     num := (num - 1)      (* in which case, decrement num *)
  292.                 else
  293.                     num := 63;
  294.                 ch := 'Y';                (* and indicate an ACK *)
  295.               end; (* else *)
  296.  
  297.         if (ch = 'Y') then
  298.            begin
  299.              if ((n mod 64) <> num) then (* if wrong ACK *)
  300.                (* stay in same state *)
  301.              else
  302.                begin
  303.                  numtry := 0;
  304.                  n := n + 1;
  305.                  current := b;
  306.                  next_is_empty := true;
  307.                  discard := sizearray[current] = at_badblk;
  308.                  if read_ch(keyport, ch) then {check for user canceling send}
  309.                    begin
  310.                      if ord(ch) in [can_cur,can_all]
  311.                        then discard := true;
  312.                      if ord(ch) = can_all
  313.                        then files_to_send := nil
  314.                    end;
  315.                  if len = 1 then {check for receiver canceling send}
  316.                    begin
  317.                      if recpkt[0] in ['X','Z']
  318.                        then discard := true;
  319.                      if recpkt[0] = 'Z'
  320.                        then files_to_send := nil
  321.                    end;
  322.                  if (sizearray[current] = at_eof) or discard then
  323.                      currstate := 'z'            (* set state to eof *)
  324.                  else
  325.                      currstate := 'd'            (* else stay in data state *)
  326.                end {else}
  327.            end (* if *)
  328.           else if (ch = 'E') then
  329.             begin
  330.               error(recpkt,len);
  331.               currstate := 'a'
  332.             end (* if 'E' *)
  333.           else if (ch = chr(0)) then      (* receive failure, so stay in d *)
  334.           else if (ch <> 'N') then
  335.             currstate := 'a'                  (* on anything else goto abort state *)
  336.       end; (* while *)
  337.     size := sizearray[current];
  338.     packet := packarray[current];
  339.     sdata := currstate
  340.   end; (* sdata *)
  341.  
  342. function sfile: char;
  343.  
  344. (* send file header *)
  345.  
  346. var num, len, i: integer;
  347.     ch: char;
  348.     fn: packettype;
  349.     oldfn: string255;
  350.  
  351. procedure legalize(var fn: string255);
  352.  
  353. (* make sure we send only 1 '.' in filename *)
  354.  
  355. var count, i, j, l: integer;
  356.  
  357.   begin
  358.     if not lit_names then
  359.       begin
  360.         count := 0;
  361.         l := length(fn);
  362.         for i := 1 to l do                                  (* count '.'s in fn *)
  363.             if fn[i] = '.' then
  364.                 count := count + 1;
  365.         for i := 1 to count-1 do                            (* remove all but 1 *)
  366.           begin
  367.             j := 1;
  368.             while (j < l) and (fn[j] <> '.') do
  369.                 j := j + 1;                                 (* by finding it *)
  370.             fn := concat(copy(fn,1,j-1),copy(fn,j+1,l-j));  (* and copying around it *)
  371.             l := l - 1
  372.           end (* for i *)
  373.       end;
  374.     i := pos(':',fn);
  375.     if i <> 0 then
  376.       fn := copy(fn,i+1,length(fn)-i)         {remove Vol. name}
  377.   end; (* legalize *)
  378.  
  379.   begin
  380.     if debug then
  381.         debugwrite('sfile');
  382.  
  383.     if (numtry > maxtry) then          (* if too many tries, give up *)
  384.       begin
  385.         sfile := 'a';
  386.         exit(sfile)
  387.       end;
  388.     numtry := numtry + 1;
  389.  
  390.     oldfn := xfilename;
  391.     legalize(xfilename);                (* make filename acceptable to remote *)
  392.     len := length(xfilename);
  393.  
  394.     moveleft(xfilename[1],fn[0],len);   (* move filename into a packettype *)
  395.  
  396.     SC_erase_to_EOL(filepos,fileline);
  397.     write(oldfn,' ==> ',xfilename);
  398.  
  399.     refresh_screen(numtry,n);
  400.  
  401.     spack('F',n mod 64,len,fn);               (* send file header packet *)
  402.  
  403.     if next_is_empty then
  404.       begin
  405.         size := bufill(packet);            (* get first data from file *)
  406.         next_is_empty := false
  407.       end;                             (* while waiting for response *)
  408.  
  409.     ch := rpack(len,num,recpkt);
  410.     if ch = 'N' then                   (* NAK, so just stay in this state *)
  411.         if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
  412.           begin
  413.             sfile := 'f';
  414.             exit(sfile)                (* is just like ACK for this packet *)
  415.           end
  416.         else
  417.           begin
  418.             if (num > 0) then
  419.                 num := (num - 1)       (* in which case, decrement num *)
  420.             else
  421.                 num := 63;
  422.             ch := 'Y';                 (* and indicate an ACK *)
  423.           end; (* else *)
  424.  
  425.     if (ch = 'Y') then
  426.       begin
  427.         if ((n mod 64) <> num) then  (* if wrong ACK, stay in F state *)
  428.           begin
  429.             sfile := 'f';
  430.             exit(sfile)
  431.           end;
  432.         numtry := 0;
  433.         n := n + 1;
  434.         do_attr := en_attr;
  435.         sfile := 'd';
  436.       end (* if *)
  437.     else if (ch = 'E') then
  438.       begin
  439.         error(recpkt,len);
  440.         sfile := 'a'
  441.       end (* if 'E' *)
  442.     else if (ch = chr(0)) then  {stay in f state}
  443.         sfile := 'f'
  444.     else if (ch <> 'N') then (* don't recognize it *)
  445.         sfile := 'a'
  446.   end; (* sfile *)
  447.  
  448. function seof: char;
  449.  
  450. (* send end of file *)
  451.  
  452. var num, len: integer;
  453.     ch: char;
  454.  
  455.   begin
  456.     if debug then
  457.         debugwrite('seof');
  458.  
  459.     if (numtry > maxtry) then          (* if too many tries, give up *)
  460.       begin
  461.         seof := 'a';
  462.         exit(seof)
  463.       end;
  464.     numtry := numtry + 1;
  465.  
  466.     refresh_screen(numtry,n);
  467.  
  468.     packet[0] := 'D';           {set up in case of discard}
  469.  
  470.     spack('Z',(n mod 64),ord(discard),packet);    (* send end of file packet *)
  471.  
  472.     if debug then
  473.         debugwrite('seof1');
  474.  
  475.     ch := rpack(len,num,recpkt);
  476.     if ch = 'N' then                   (* NAK, so just stay in this state *)
  477.         if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
  478.           begin
  479.             seof := 'z';
  480.             exit(seof)                 (* is just like ACK for this packet *)
  481.           end
  482.         else
  483.           begin
  484.             if num > 0 then
  485.                 num := (num - 1)       (* in which case, decrement num *)
  486.             else
  487.                 num := 63;
  488.             ch := 'Y';                 (* and indicate an ACK *)
  489.           end; (* else *)
  490.  
  491.     if (ch = 'Y') then
  492.       begin
  493.         if debug then
  494.             debugwrite('seof2');
  495.         if ((n mod 64) <> num) then     (* if wrong ACK, stay in Z state *)
  496.           begin
  497.             seof := 'z';
  498.             exit(seof)
  499.           end;
  500.         numtry := 0;
  501.         n := n + 1;
  502.         if debug then
  503.             debugwrite(concat('Closing ',xfilename));
  504.         if f_is_binary
  505.           then close(b_file)
  506.           else close(t_file);
  507.         while files_to_send <> nil do with files_to_send^ do
  508.           begin
  509.             xfilename := concat(D_volume,':',D_title);
  510.             seof := 'f';
  511.             next_is_empty := true;
  512.  
  513.             openfile;
  514.             files_to_send := D_next_entry;
  515.             if io_status <> 0
  516.               then io_error(io_status)
  517.               else exit(seof)
  518.           end {while};
  519.         seof := 'b'
  520.       end (* if *)
  521.     else if (ch = 'E') then
  522.       begin
  523.         error(recpkt,len);
  524.         seof := 'a'
  525.       end (* if 'E' *)
  526.     else if (ch = chr(0)) then         (* receive failed, so stay in z state *)
  527.         seof := 'z'
  528.     else if (ch <> 'N') then           (* other error, just abort *)
  529.         seof := 'a'
  530.   end; (* seof *)
  531.  
  532. function sbreak: char;
  533.  
  534. var num, len: integer;
  535.     ch: char;
  536.  
  537. (* send break (end of transmission) *)
  538.  
  539.   begin
  540.     if debug then
  541.         debugwrite('sbreak');
  542.  
  543.     if (numtry > maxtry) then          (* if too many tries, give up *)
  544.       begin
  545.         sbreak := 'a';
  546.         exit(sbreak)
  547.       end;
  548.     numtry := numtry + 1;
  549.  
  550.     refresh_screen(numtry,n);
  551.  
  552.     spack('B',(n mod 64),0,packet);    (* send Break Transfer packet *)
  553.  
  554.     ch := rpack(len,num,recpkt);
  555.     if ch = 'N' then                   (* NAK, so just stay in this state *)
  556.         if ((n+1) mod 64 <> num) then  (* unless NAK for next packet, which *)
  557.           begin
  558.             sbreak := 'b';
  559.             exit(sbreak)               (* is just like ACK for this packet *)
  560.           end
  561.         else
  562.           begin
  563.             if num > 0 then
  564.                 num := (num - 1)       (* in which case, decrement num *)
  565.             else
  566.                 num := 63;
  567.             ch := 'Y';                 (* and indicate an ACK *)
  568.           end; (* else *)
  569.  
  570.     if (ch = 'Y') then
  571.       begin
  572.         if ((n mod 64) <> num) then    (* if wrong ACK, stay in B state *)
  573.           begin
  574.             sbreak := 'b';
  575.             exit(sbreak)
  576.           end;
  577.         numtry := 0;
  578.         n := n + 1;
  579.         sbreak := 'c'                  (* else, switch state to complete *)
  580.       end (* if *)
  581.     else if (ch = 'E') then
  582.       begin
  583.         error(recpkt,len);
  584.         sbreak := 'a'
  585.       end (* if 'E' *)
  586.     else if (ch = chr(0)) then         (* receive failed, so stay in b state *)
  587.         sbreak := 'b'
  588.     else if (ch <> 'N') then           (* other error, just abort *)
  589.         sbreak := 'a'
  590.   end; (* sbreak *)
  591.  
  592. (* state table switcher for sending *)
  593.  
  594.   begin (* sendsw *)
  595.     mark(heap);
  596.     send_ok := false;
  597.     still_sending :=
  598.         D_dirlist(xfilename,[D_code..D_svol],files_to_send,false) = D_okay;
  599.     if files_to_send <> nil then with files_to_send^ do
  600.       begin
  601.         xfilename := concat(D_volume,':',D_title);
  602.         next_is_empty := true;
  603.  
  604.         openfile;
  605.         files_to_send := D_next_entry;
  606.         if io_status <> 0 then
  607.           begin
  608.             io_error(io_status);
  609.             still_sending := false
  610.           end
  611.       end;
  612.  
  613.     if still_sending then write_screen('Sending');
  614.     currstate := 's';
  615.     n := 0;       (* set packet # *)
  616.     numtry := 0;
  617.     flush_comm;         {flush any garbage in buffer}
  618.  
  619.     while still_sending do
  620.         if currstate in ['d', 'f', 'z', 's', 'b', 'c', 'a'] then
  621.           case currstate of
  622.               'd': if do_attr
  623.                      then currstate := sattr
  624.                      else currstate := sdata;
  625.               'f': currstate := sfile;
  626.               'z': currstate := seof;
  627.               's': currstate := sinit;
  628.               'b': currstate := sbreak;
  629.               'c': begin
  630.                      send_ok := true;
  631.                      still_sending := false
  632.                    end; (* case c *)
  633.               'a': still_sending := false
  634.             end (* case *)
  635.         else (* state not in legal states *)
  636.           begin
  637.             debugwrite('Unknown State');
  638.             still_sending := false
  639.           end (* else *);
  640.     release(heap)
  641.   end; (* sendsw *)
  642.  
  643. procedure sen_version;
  644.  
  645.   begin
  646.     writeln(my_version)
  647.   end {sen_version};
  648.  
  649. end. { sender }
  650.