home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
ftp.barnyard.co.uk
/
2015.02.ftp.barnyard.co.uk.tar
/
ftp.barnyard.co.uk
/
cpm
/
walnut-creek-CDROM
/
CPM
/
TURBOPAS
/
PMODEM.ARK
/
SEND.INC
< prev
next >
Wrap
Text File
|
1987-02-22
|
4KB
|
184 lines
{********** send.inc **********}
{ send file }
var
CRC, checksum : integer;
procedure calcCRC(b: byte);
var
carry: boolean;
i: byte;
begin
checksum:= lo(checksum + b);
for i:= 0 to 7 do begin
carry:= (CRC and $8000) <> 0;
CRC:= CRC shl 1;
if (b and $80) <> 0 then CRC:= CRC or $0001;
if carry then CRC:= CRC xor $1021;
b:= lo(b shl 1);
end;
end; {calcCRC}
procedure send_it;
label loop2;
var
inch, ch, ch1: char;
blocknum, numberofrecords, min, sec, tries: integer;
Loop: byte;
done, crcOn: boolean;
buffer: array[1..128] of byte;
function roundUp(numb: real): integer;
{roundUp to next whole number if numb not whole number}
begin
if numb <> Trunc(numb) then numb:= numb+1;
roundUp:= Trunc(numb);
end; {roundUp}
procedure send_time(numberofrecords: integer; var min, sec: integer);
{compute file send time re. ROS32.PAS}
var
time: real;
begin
time:= 0.02075 * numberofrecords;
if not hiBaud then time:= time * 4;
min:= trunc(time);
sec:= round(60.0 * frac(time));
if sec = 60 then begin
min:= min + 1;
sec:= 0;
end;
end; {send_time}
procedure sendcalc(b: byte);
begin
xmit(b);
calcCRC(b);
end; {sendcalc}
procedure acknak(var inch: char; time: integer);
label lbl;
var
loop, loopend: integer;
begin
loopend:= 100 * time;
loop:= 0;
inch:= '0';
repeat
delay(10);
if keypressed then
begin
read(kbd, inch);
if inch <> CAN then inch:= '0'
else goto lbl;
end;
until modem_in_ready or not carrier or (loop >= loopend);
inch:= modem_in;
LBL:
if not (inch in [ACK, NAK, CAN, 'C', 'K']) then inch:= '0';
end; {acknak}
begin {send_it}
openFile(sourceName);
numberofrecords:= fileSize(sourceFile);
send_time(numberofrecords, min, sec);
write(numberofrecords, ' records (', roundUp(numberofrecords/8), 'k) ');
write('[', min, ' minute');
if min <> 1 then write('s');
write(' ', sec, ' second');
if sec <> 1 then write('s');
writeln(']');
crcOn:= false;
done:= false;
tries:= 0;
blocknum:= 1;
blockread(SourceFile, buffer, 1);
acknak(inch, 60);
repeat
if inch = 'C' then acknak(inch, 60);
if inch = 'K' then write('k');
if inch in ['C', 'K'] then CrcOn:= true;
if inch = 'C' then write('c');
until inch in ['C', 'K', NAK, CAN];
{now do block}
repeat
if inch = ACK then begin
write(CR, blocknum); clrEol;
if eof(SourceFile) then done := true else begin
blockread(SourceFile, buffer, 1);
blocknum:= blocknum +1;
tries:= 0
end;
end
else begin write('.'); tries:= tries + 1; end;
if not (inch in [CAN]) { '0'])} and carrier and not done then begin
{send block number}
modem_out(SOH);
xmit(lo(blocknum)); xmit(not lo(blocknum));
checksum:= 0;
CRC:= 0;
{send block}
for loop:= 1 to 128 do sendcalc(buffer[loop]);
calcCRC(0);
calcCRC(0);
if crcOn then begin xmit(hi(CRC)); xmit(lo(CRC)); end
else xmit(checksum);
end;
acknak(inch, 60);
until (inch = CAN) or done or not carrier or (tries > 30);
{wrap it up}
repeat
modem_out(EOT);
sinp(ch1);
if ch1 = ^X then goto loop2;
tries:= tries + 1;
until modem_in_ready {(modem_in = ACK)} or not carrier or (tries > 10);
writeln(BELL);
writeln('++ transfer completed ++');
LOOP2:
close(sourceFile);
eraseOK:= false;
writeln;
terminal_mode;
end; {send_it}
procedure send_a_file;
label re_name;
var
sas: boolean;
begin
write('SEND file');
delete(line,1,1); sas:= false;
if upCase(line[1]) = 'A' then begin
sas:= true;
writeln(' (ASCII)');
end else writeln;
writeln;
timein;
re_name:
write('Enter NAME of file to send: ');
readln(temp1); upper(temp1);
if temp1[1] in [^@..' '] then temp1:= '';
if length(temp1)>0 then sourceName:= temp1
else begin
writeln;
eraseOK:= false;
terminal_mode;
end;
if not findfile(sourceName) then begin
writeln('++ file ', sourceName, ' not found ++');
goto re_name;
end;
if sas = true then send_ascii
else send_it;
end;