Category : Pascal Source Code
Archive : WWIV310.ZIP
Filename : DLP1.PAS
Output of file : DLP1.PAS contained in archive : WWIV310.ZIP
var rl:real; c:integer;
begin
rl:=0;
c:=1;
while (c
c:=c+1;
end;
while (i<>'') do begin
c:=ord(i[1])-ord('0');
rl:=rl*10.0+c;
i:=copy(i,2,length(i)-1);
end;
valuer:=rl;
end;
function cstrr(rl:real):str;
var c1,c2,c3:integer; i:str; r1,r2:real;
begin
if rl<=0.0 then cstrr:='0' else begin
r1:=ln(rl)/ln(10.0);
r2:=exp(ln(10)*(trunc(r1)));
i:='';
while (r2>0.999) do begin
c1:=trunc(rl/r2);
i:=i+chr(c1+ord('0'));
rl:=rl-c1*r2;
r2:=r2/10.0;
end;
cstrr:=i;
end;
end;
procedure calcCRC(data:byte);
var
i: byte;
begin
chksum := lo(chksum + data);
if ucrc then begin
crc:=crc xor (data shl 8);
for i := 0 to 7 do begin
if (crc<0) then
crc:=(crc shl 1) xor $1021
else
crc:=crc shl 1;
end;
end;
end;
function gtp(dl:boolean):integer;
var c:char; s:str; done:boolean;
begin
if dl then s:='01234Q?' else s:='0234Q?';
done:=false;
repeat
nl;
prompt('Protocol (?=list) : '); onek(c,s);
if c='?' then begin
nl;
print('Q) abort transfer');
print('0) don''t transfer');
if dl then print('1) ASCII transfer (download only)');
print('2) XMODEM');
print('3) XMODEM-CRC');
print('4) YMODEM');
end else done:=true;
until done or hangup;
if c='Q' then gtp:=-1 else gtp:=value(c+'');
end;
procedure sendascii(fn:str);
var f:file of char; c,c1:char; abort:boolean; i:integer;
procedure ckey;
begin
checkhangup;
while (not empty) and (not abort) do begin
if hangup then abort:=true;
c1:=inkey;
if (c1=^X) or (c1=#27) or (c1=' ') then abort:=true;
if c1=^S then getkey(c1);
end;
end;
begin
assign(f,fn);
{$I-} reset(f); {$I+}
if ioresult<>0 then print('File not found.') else begin
abort:=false;
clrscr;
writeln('File: ',fn);
writeln('
writeln;
gotoxy(1,5);
for i:=1 to 80 do write(#205);
gotoxy(1,17);
for i:=1 to 80 do write(#205);
window(1,10,80,20);
clrscr;
print('^X=ABORT');
print('^S=PAUSE'); nl;
while (not abort) and (not eof(f)) do begin
read(f,c); o(c); if (c<>#7) then write(c); ckey;
end;
close(f);
if useron then window(1,5,80,25) else window(1,1,80,25); gotoxy(1,19);
nl; nl; print('> FILE TRANSMISSION COMPLETE');
end;
end;
procedure send(fn:str; var dok:boolean);
var filv:file; try,mb,bn,ers,lbn:integer; done,abort:boolean; st,start:real; c:char;
x,y:integer; bfr:array [0..1023] of byte; numbt,numba:integer;
procedure sb(bn:integer);
var bp:real; onumbt,c:integer;
procedure mb0;
var i:str; c:integer;
begin
i:=fn;
while pos(' ',i)>0 do delete(i,pos(' ',i),1);
for c:=1 to length(i) do
if i[c] in ['A'..'Z'] then
i[c]:=chr(ord(i[c])-ord('A')+ord('a'));
i:=i+#0+cstrr(longfilesize(filv));
for c:=1 to length(i) do bfr[c-1]:=ord(i[c]);
numbt:=128; numba:=length(i);
end;
begin
crc:=0; chksum:=0; onumbt:=numbt;
if bn=0 then mb0 else begin
bp:=(lbn*1.0-1.0)*128.0;
longseek(filv,bp);
blockread(filv,bfr[0],numbt,numba);
end;
for c:=numba to numbt-1 do bfr[c]:=0; c:=0;
if numbt=1024 then o1(#2) else o1(#1); o1(chr(lo(bn))); o1(chr(lo(bn) xor 255));
while (c
end;
if ucrc then begin o1(chr(hi(crc))); o1(chr(lo(crc))); end else o1(chr(chksum));
dump; numbt:=onumbt;
end;
procedure sblock(bn:integer; var abort:boolean);
var start:real; done:boolean; b:blk; try,i:integer; c:char;
procedure ckbd;
begin
if keypressed then begin
read(kbd,c); if c=#27 then begin abort:=true; done:=true;
gotoxy(1,6); write('ABORTED FROM KEYBOARD'); end;
end;
end;
begin
try:=1; abort:=false;
checkhangup;
done:=false;
while (not done) and (not hangup) do begin
gotoxy(20,3); write(bn); if ymodem then write('-',lbn);
gotoxy(20,4); write(try-1);
gotoxy(20,5); write(ers);
sb(bn);
start:=timer;
while tcheck(start,20) and (not commpressed) and (not hangup) and (not abort)
do begin checkhangup; ckbd; end;
ckbd;
if commpressed then c:=cinkey1 else c:=#21;
case c of
#6:done:=true;
#24:begin done:=true; abort:=true; gotoxy(1,6); write('ABORTED REMOTELY '); end;
else begin try:=try+1; ers:=ers+1; if try>9 then begin
abort:=true; done:=true;
gotoxy(1,6); write('EXCESSIVE ERRORS ');
end;
end;
end;
end;
end;
function ok:boolean;
var start:real; c:char; try:integer; done:boolean;
begin
done:=false; abort:=false; start:=timer;
while tcheck(timer,90) and (not done) and (not abort) and (not hangup) do begin
checkhangup;
if keypressed then begin
read(kbd,c);
if c=#27 then begin
gotoxy(1,6); write('ABORTED FROM KEYBOARD');
abort:=true;
end;
end;
if commpressed then begin
c:=cinkey1;
if c=#21 then begin ucrc:=false; done:=true; end;
if c='C' then begin ucrc:=true; done:=true; end;
if c=#24 then begin abort:=true;
gotoxy(1,6); write('ABORTED REMOTELY ');
end;
end;
end;
if not tcheck(timer,90) then begin
gotoxy(1,6); write('TIMEOUT ERROR ');
abort:=true;
end;
ok:=(not abort) and (not hangup);
end;
begin
assign(filv,fn); ers:=0; if ymodem then numbt:=1024 else numbt:=128;
{$I-} reset(filv,1); {$I+}
if ioresult=0 then begin
mb:=trunc((longfilesize(filv)+127.0)/128.0);
if useron then print('> WAITING FOR START, ^X to abort'); x:=wherex; y:=wherey;
for bn:=1 to 6 do begin gotoxy(49,bn); write(#186); end;
gotoxy(49,7); write(#200); for bn:=1 to 30 do write(#205);
if useron then window(50,5,80,10) else window(50,1,80,6);
clrscr; writeln('File: ',fn);
writeln('Total blocks = ',mb);
writeln('Current block = 0');
writeln('# consec. errors = 0');
writeln('# errors = 0');
write('
if ok then begin
bn:=1; lbn:=1; try:=1;
if ft<>255 then begin
while (not abort) do begin
o1(#$81); o1(chr(ft)); o1(chr(ft xor $ff));
st:=timer; try:=try+1;
while tcheck(st,3) and not commpressed do;
if tcheck(st,6) then c:=cinkey else try:=try+1;
if (c=#6) or (try>4) then abort:=true;
end;
abort:=false; try:=1;
end;
if ymodem then sblock(0,abort);
while (not abort) and (lbn<=mb) do begin
sblock(bn,abort);
bn:=bn+1; if ymodem then lbn:=lbn+8 else lbn:=lbn+1;
end;
if not abort then begin
try:=1; done:=false;
repeat
start:=timer;
gotoxy(20,3); write('EOT '); o1(#4); clreol;
while tcheck(start,10) and not commpressed and not hangup do checkhangup;
if commpressed then begin
c:=cinkey1; if c=#6 then begin
done:=true;
end;
end;
if not done then try:=try+1;
until (try>9) or hangup or done;
end;
end;
close(filv);
if useron then window(1,5,80,25) else window(1,1,80,25);
gotoxy(x,y);
dok:=not abort;
if dok then begin
thisuser.downloads:=thisuser.downloads+1;
thisuser.dk:=thisuser.dk+((mb+4) div 8);
print('> FILE TRANSMISSION COMPLETE');
end;
end else print('File not found.');
end;
procedure receive(fn:str; var dok:boolean);
var f:file; r1:array[0..1023] of byte; nbts,x,y,terr,xx,t1,csum,try,block,lblk,len:integer; b,b1,b2:byte; c:char;
bn0,start,abort,error,done,timeo,kba,sav:boolean; rl,rl1,rfl:real;
const nak=#21;
ack=#06;
can=#24;
soh=#01;
procedure onec(var b:byte);
var r:real; c:char; i:byte;
begin
if buffer_Head<>buffer_Tail then begin
inline($FA);
b:=ord(buffer[buffer_Tail]);
buffer_Tail:=(buffer_Tail+1) mod (buffer_max+1);
inline($FB);
end else begin
r:=timer;
while (not commpressed) and tchk(r,1.0) do checkhangup;
if commpressed then b:=ord(cinkey1) else begin timeo:=true; b:=0; end;
if timeo then error:=true;
if hangup then begin error:=true; done:=true; abort:=true; end;
end;
if ucrc then begin
crc:=crc xor (b shl 8);
for i := 0 to 7 do begin
if (crc<0) then
crc:=(crc shl 1) xor $1021
else
crc:=crc shl 1;
end;
end else chksum := lo(chksum + b);
end;
function onec1:byte;
var r:real; c:char;
begin
checkhangup;
r:=timer;
while (not commpressed) and tcheck(r,6) and (not hangup) do checkhangup;
if commpressed then onec1:=ord(cinkey1) else begin timeo:=true; onec1:=0; end;
if timeo then error:=true;
if hangup then begin error:=true; done:=true; abort:=true; end;
end;
procedure checkkb;
var c:char;
begin
if keypressed then begin read(kbd,c); if c=#27 then begin
done:=true; abort:=true; gotoxy(5,5); writeln('ABORTED FROM KEYBOARD'); clreol; kba:=true; end;
end;
end;
procedure rb0;
var i:str; c:integer;
begin
c:=0; while (r1[c]<>0) and (c<100) do c:=c+1;
c:=c+1; i:='';
while (chr(r1[c]) in ['0'..'9']) and (length(i)<10) do begin
i:=i+chr(r1[c]);
c:=c+1;
end;
rfl:=valuer(i); if rfl<0.0 then rfl:=0.0;
end;
begin
abort:=false; done:=false; timeo:=false; kba:=false;
block:=1; try:=1; start:=false; lblk:=1;
assign(f,fn); rl1:=timer; rfl:=0.0;
{$I-} rewrite(f,1);{$I+}
if ioresult<>0 then begin
print('> DISK ERROR, SORRY CAN''T UPLOAD IT.');
done:=true; abort:=true;
end;
if useron then print('> WAITING FOR START, ^X to abort'); x:=wherex; y:=wherey;
for terr:=1 to 6 do begin gotoxy(49,terr); write(#186); end;
gotoxy(49,7); write(#200); for terr:=1 to 30 do write(#205);
if useron then window(50,5,80,10) else window(50,1,80,6);
clrscr; writeln('File: '+fn);
writeln('Block number = 0');
writeln('Consec errors = 0');
writeln('Total errors = 0');
writeln('ER:');
write('
error:=true; terr:=0; bn0:=false;
while (not done) and (not hangup) do begin
gotoxy(17,3); write(try-1); gotoxy(17,4); write(terr); gotoxy(17,2); write(block,'-',lblk);
checkkb; if kba then begin done:=true; abort:=true; end;
if kba then o1(can) else
if error then begin if (block=1) and ucrc then o1('C') else o1(nak);
dump; if block<>1 then terr:=terr+1; try:=try+1;
gotoxy(17,3); write(try-1); gotoxy(17,4); write(terr); gotoxy(17,2); write(block,'-',lblk);
end else begin
o1(ack); dump;
if bn0 then rb0;
bn0:=false;
if sav and (not error) then begin
try:=1;
longseek(f,(lblk-1.0)*128.0);{$I-} blockwrite(f,r1,nbts); {$I+} if ioresult<>0 then begin
done:=true; abort:=true; gotoxy(5,5); write('DISK ERROR'); clreol;
sysoplog('Disk error in upload');
end;
block:=block+1; if ymodem then lblk:=lblk+8 else lblk:=lblk+1;
end else
begin gotoxy(5,5); write('Low block number ',block-1); clreol; end;
end;
if (not done) and (not abort) and (not hangup) then begin
start:=false; t1:=0;
while (not start) and (not hangup) and (not abort) do begin
timeo:=false;
b:=onec1;
if b=$81 then begin
b1:=onec1; b2:=onec1;
if b1=(b2 xor $ff) then begin
ft:=b1; o1(ack);
end else o1(nak);
end;
if b=ord(soh) then begin start:=true; ymodem:=false; end;
if b=2 then begin start:=true; ymodem:=true; end;
if b=ord(can) then begin abort:=true; done:=true; gotoxy(5,5); write('ABORTED REMOTELY'); clreol; end;
if b=04 then begin o1(ack); start:=true; done:=true; gotoxy(5,5); write('EOT RECEIVED'); clreol; end;
if timeo then begin if (block=1) and ucrc then o1('C') else o1(nak); t1:=t1+1; end;
if t1>=9 then begin start:=true; abort:=true; done:=true; end;
end;
if kba then begin o1(can); gotoxy(5,5); write('ABORTED FROM KEYBOARD'); clreol; end;
if try>9 then begin abort:=true; done:=true; gotoxy(5,5); write('ABORTING - too many errors'); clreol; end;
if t1>=9 then begin abort:=true; done:=true; gotoxy(5,5); write('TIMEOUT'); clreol; end;
error:=false; checkkb;
if not done then begin
gotoxy(17,3); write(try-1); gotoxy(17,4); write(terr); gotoxy(17,2); write(block,'-',lblk);
sav:=true;
onec(b1); if b1<>lo(block) then
if (b1+1) mod 256=lo(block) then begin
sav:=false;
if (block=1) and (b1=0) then bn0:=true;
end else begin
error:=true; gotoxy(5,5); write('bn was ',b1,' vs. ',lo(block)); clreol;
end;
onec(b); if b xor 255<>b1 then begin error:=true; gotoxy(5,5); write('com was ',b,' vs. ',b1 xor 255); clreol; end
else if sav and (b1<>lo(block)) then begin abort:=true; done:=true; end;
len:=0; chksum:=0; crc:=0; if ymodem then nbts:=1024 else nbts:=128;
while (len
len:=len+1;
end;
xx:=crc; csum:=chksum;
onec(b); if ucrc then onec(b1);
if not error then begin
if ((b<>lo(csum)) and (not ucrc)) or
(((b<>hi(xx)) or (b1<>lo(xx))) and ucrc)
then begin error:=true; gotoxy(5,5); write('Checksum/CRC error in ',block); clreol; end;
end;
end;
if abort then o1(can);
end;
end;
if (rfl>0.1) and (rfl<=longfilesize(f)) then begin
longseek(f,rfl-1.0);
truncate(f);
end;
close(f);
if useron then window(1,5,80,25) else window(1,1,80,25);
gotoxy(x,y);
if hangup then abort:=true;
if abort then erase(f) else
begin
thisuser.uploads:=thisuser.uploads+1;
thisuser.uk:=thisuser.uk+((lblk+3) div 8);
writeln('> TRANSFER COMPLETED');
if timer
systat.uptoday:=systat.uptoday+1;
end;
dok:=not abort;
end;
procedure send1(fn:str; var dok,abort:boolean);
var i:integer;
begin
i:=gtp(true); dok:=true; abort:=false;
if not useron then begin incom:=true; outcom:=true; if i=1 then i:=0; end;
case i of
-1:begin dok:=false; abort:=true; end;
0:dok:=false;
1:sendascii(fn);
2:if incom then begin ucrc:=false; ymodem:=false; send(fn,dok); end;
3:if incom then begin ucrc:=true; ymodem:=false; send(fn,dok); end;
4:if incom then begin ucrc:=true; ymodem:=true; send(fn,dok); end;
end;
if (i<=1) and (not incom) then dok:=false;
if useron then
if i>1 then
if dok then
sysoplog('Downloaded "'+fn+'"')
else
sysoplog('Tried D/L "'+fn+'"')
else
if i=1 then
sysoplog('Text D/L "'+fn+'"')
else
else begin incom:=false; outcom:=false; end;
end;
procedure receive1(fn:str; var dok:boolean);
var i:integer;
begin
i:=gtp(false); dok:=true;
if not useron then begin incom:=true; outcom:=true; end;
case i of
-1:dok:=false;
0:dok:=false;
2:begin ucrc:=false; ymodem:=false; receive(fn,dok); end;
3:begin ucrc:=true; ymodem:=false; receive(fn,dok); end;
4:begin ucrc:=true; ymodem:=true; receive(fn,dok); end;
end;
if not useron then begin incom:=false; outcom:=false; end;
end;
Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!
This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.
But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/