home *** CD-ROM | disk | FTP | other *** search
/ Oakland CPM Archive / oakcpm.iso / cpm / turbopas / pmodem.ark / SEND.INC < prev    next >
Encoding:
Text File  |  1987-02-22  |  4.3 KB  |  184 lines
  1. {********** send.inc **********}
  2.           { send file }
  3.  
  4. var
  5.   CRC, checksum : integer;
  6.  
  7. procedure calcCRC(b: byte);
  8. var
  9.   carry: boolean;
  10.   i: byte;
  11. begin
  12.  checksum:= lo(checksum + b);
  13.  for i:= 0 to 7 do begin
  14.    carry:= (CRC and $8000) <> 0;
  15.    CRC:= CRC shl 1;
  16.    if (b and $80) <> 0 then CRC:= CRC or $0001;
  17.    if carry then CRC:= CRC xor $1021;
  18.    b:= lo(b shl 1);
  19.  end;
  20. end; {calcCRC}
  21.  
  22. procedure send_it;
  23. label loop2;
  24. var
  25.   inch, ch, ch1: char;
  26.   blocknum, numberofrecords, min, sec, tries: integer;
  27.   Loop: byte;
  28.   done, crcOn: boolean;
  29.   buffer: array[1..128] of byte;
  30.  
  31. function roundUp(numb: real): integer;
  32. {roundUp to next whole number if numb not whole number}
  33. begin
  34.   if numb <> Trunc(numb) then numb:= numb+1;
  35.   roundUp:= Trunc(numb);
  36. end; {roundUp}
  37.  
  38. procedure send_time(numberofrecords: integer; var min, sec: integer);
  39. {compute file send time re. ROS32.PAS}
  40. var
  41.   time: real;
  42. begin
  43.   time:= 0.02075 * numberofrecords;
  44.   if not hiBaud then time:= time * 4;
  45.   min:= trunc(time);
  46.   sec:= round(60.0 * frac(time));
  47.   if sec = 60 then begin
  48.     min:= min + 1;
  49.     sec:= 0;
  50.   end;
  51. end; {send_time}
  52.  
  53. procedure sendcalc(b: byte);
  54. begin
  55.   xmit(b);
  56.   calcCRC(b);
  57. end; {sendcalc}
  58.  
  59. procedure acknak(var inch: char; time: integer);
  60. label lbl;
  61. var
  62.   loop, loopend: integer;
  63. begin
  64.   loopend:= 100 * time;
  65.   loop:= 0;
  66.   inch:= '0';
  67.   repeat
  68.     delay(10);
  69.     if keypressed then
  70.     begin
  71.       read(kbd, inch);
  72.       if inch <> CAN then inch:= '0'
  73.     else goto lbl;
  74.     end;
  75.   until modem_in_ready or not carrier or (loop >= loopend);
  76.   inch:= modem_in;
  77. LBL:
  78.   if not (inch in [ACK, NAK, CAN, 'C', 'K']) then inch:= '0';
  79. end; {acknak}
  80.  
  81. begin  {send_it}
  82.   openFile(sourceName);
  83.   numberofrecords:= fileSize(sourceFile);
  84.   send_time(numberofrecords, min, sec);
  85.   write(numberofrecords, ' records (', roundUp(numberofrecords/8), 'k)  ');
  86.   write('[', min, ' minute');
  87.     if min <> 1 then write('s');
  88.     write(' ', sec, ' second');
  89.      if sec <> 1 then write('s');
  90.     writeln(']');
  91.   crcOn:= false;
  92.   done:= false;
  93.   tries:= 0;
  94.   blocknum:= 1;
  95.   blockread(SourceFile, buffer, 1);
  96.  
  97.    acknak(inch, 60);
  98.  
  99.   repeat
  100.    if inch = 'C' then acknak(inch, 60);
  101.  
  102.    if inch = 'K' then write('k');
  103.  
  104.    if inch in ['C', 'K'] then CrcOn:= true;
  105.    if inch = 'C' then write('c');
  106.   until inch in ['C', 'K', NAK, CAN];
  107.  
  108.  {now do block}
  109.   repeat
  110.    if inch = ACK then begin
  111.     write(CR, blocknum); clrEol;
  112.     if eof(SourceFile) then done := true else begin
  113.      blockread(SourceFile, buffer, 1);
  114.      blocknum:= blocknum +1;
  115.      tries:= 0
  116.     end;
  117.    end
  118.    else begin write('.'); tries:= tries + 1; end;
  119.  
  120.    if not (inch in [CAN]) { '0'])} and carrier and not done then begin
  121.    {send block number}
  122.     modem_out(SOH);
  123.     xmit(lo(blocknum)); xmit(not lo(blocknum));
  124.     checksum:= 0;
  125.     CRC:= 0;
  126.     {send block}
  127.     for loop:= 1 to 128 do sendcalc(buffer[loop]);
  128.     calcCRC(0);
  129.     calcCRC(0);
  130.     if crcOn then begin xmit(hi(CRC)); xmit(lo(CRC)); end
  131.       else xmit(checksum);
  132.    end;
  133.  
  134.    acknak(inch, 60);
  135.  
  136.  until (inch = CAN) or done or not carrier or (tries > 30);
  137.   {wrap it up}
  138.   repeat
  139.     modem_out(EOT);
  140.     sinp(ch1);
  141.     if ch1 = ^X then goto loop2;
  142.     tries:= tries + 1;
  143.   until modem_in_ready {(modem_in = ACK)} or not carrier or (tries > 10);
  144.   writeln(BELL);
  145.   writeln('++ transfer completed ++');
  146. LOOP2:
  147.   close(sourceFile);
  148.   eraseOK:= false;
  149.   writeln;
  150.   terminal_mode;
  151. end; {send_it}
  152.  
  153.  
  154. procedure send_a_file;
  155. label re_name;
  156. var
  157.   sas: boolean;
  158. begin
  159.   write('SEND file');
  160.   delete(line,1,1); sas:= false;
  161.   if upCase(line[1]) = 'A' then begin
  162.     sas:= true;
  163.     writeln(' (ASCII)');
  164.   end else writeln;
  165.   writeln;
  166.   timein;
  167. re_name:
  168.   write('Enter NAME of file to send: ');
  169.   readln(temp1); upper(temp1);
  170.   if temp1[1] in [^@..' '] then temp1:= '';
  171.   if length(temp1)>0 then sourceName:= temp1
  172.   else begin
  173.     writeln;
  174.     eraseOK:= false;
  175.     terminal_mode;
  176.   end;
  177.   if not findfile(sourceName) then begin
  178.     writeln('++ file ', sourceName, ' not found ++');
  179.     goto re_name;
  180.   end;
  181.   if sas = true then send_ascii
  182.   else send_it;
  183. end;
  184.