eric
/
telegard
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
telegard/file8.pas

339 lines
9.6 KiB
ObjectPascal
Raw Permalink Blame History

{$A+,B+,E+,F+,I+,L+,N-,O+,R-,S+,V-}
unit file8;
interface
uses
crt,dos,
{rcg11172000 no overlay under Linux.}
{overlay,}
myio,
file0, file6, file7,
execbat,
common;
procedure ymbadd(fname:astr);
procedure send1(fn:astr; var dok,kabort:boolean);
procedure receive1(fn:astr; resumefile:boolean; var dok,kabort,addbatch:boolean);
implementation
procedure abeep;
var a,b,c,i,j:integer;
begin
for j:=1 to 3 do begin
for i:=1 to 3 do begin
a:=i*500;
b:=a;
while (b>a-300) do begin
sound(b);
dec(b,50);
c:=a+1000;
while (c>a+700) do begin
sound(c); dec(c,50);
delay(2);
end;
end;
end;
delay(50);
nosound;
end;
end;
function checkfileratio:integer;
var i,r,t:real;
j:integer;
badratio:boolean;
begin
t:=thisuser.dk;
if (numbatchfiles<>0) then
for j:=1 to numbatchfiles do begin
loaduboard(batch[j].section);
if (not (fbnoratio in memuboard.fbstat)) then
t:=t+(batch[j].blks div 8);
end;
badratio:=FALSE;
r:=(t+0.001)/(thisuser.uk+0.001);
if (r>systat.dlkratio[thisuser.sl]) then badratio:=TRUE;
i:=(thisuser.downloads+numbatchfiles+0.001)/(thisuser.uploads+0.001);
if (i>systat.dlratio[thisuser.sl]) then badratio:=TRUE;
if ((aacs(systat.nodlratio)) or (fnodlratio in thisuser.ac)) then
badratio:=FALSE;
if (not systat.uldlratio) then badratio:=FALSE;
checkfileratio:=0;
if (badratio) then
if (numbatchfiles=0) then checkfileratio:=1 else checkfileratio:=2;
loaduboard(fileboard);
if (fbnoratio in memuboard.fbstat) then checkfileratio:=0;
end;
procedure ymbadd(fname:astr);
var t1,t2:real;
f:file of byte;
ff:ulfrec;
dt:datetimerec;
sof:longint;
ior:word;
slrn,rn,pl,fblks:integer;
slfn:astr;
ffo:boolean;
begin
ffo:=(filerec(ulff).mode<>fmclosed);
nl;
fname:=sqoutsp(fname);
if (exist(fname)) then begin
assign(f,fname); reset(f);
sof:=filesize(f);
fblks:=trunc((sof+127.0)/128.0);
t1:=rte*fblks;
close(f);
t2:=batchtime+t1;
if (t2>nsl) then print('Not enough time left in queue.')
else
if (numbatchfiles=20) then print('Batch queue full.')
else begin
inc(numbatchfiles);
with batch[numbatchfiles] do begin
if (fileboard<>-1) then begin
slrn:=lrn; slfn:=lfn;
if ffo then close(ulff);
recno(stripname(fname),pl,rn);
seek(ulff,rn); read(ulff,ff);
close(ulff);
if ffo then fiscan(pl);
lrn:=slrn; lfn:=slfn;
pts:=ff.filepoints;
blks:=ff.blocks;
end else begin
pts:=unlisted_filepoints;
blks:=fblks;
end;
fn:=sqoutsp(fname);
tt:=t1;
section:=fileboard;
batchtime:=t2;
sysoplog('Added '+stripname(fn)+' to batch queue.');
sprint(fstring.batchadd);
r2dt(batchtime,dt);
print('Batch - Files: '+cstr(numbatchfiles)+' Time: '+longtim(dt));
end;
end;
end else
print('File doesn''t exist');
end;
procedure addtologupdown;
var s:astr;
begin
s:=' ULs: '+cstr(trunc(thisuser.uk))+'k in '+cstr(thisuser.uploads)+' file';
if thisuser.uploads<>1 then s:=s+'s';
s:=s+' - DLs: '+cstr(trunc(thisuser.dk))+'k in '+cstr(thisuser.downloads)+' file';
if thisuser.downloads<>1 then s:=s+'s';
sysoplog(s);
end;
procedure send1(fn:astr; var dok,kabort:boolean);
var f:text;
ff:file;
f1:ulfrec;
nfn,cp,slfn,s:astr;
st:real;
filsize:longint;
dcode:word; { dos exit code }
p,i,sx,sy,t,pl,rn,slrn,errlevel:integer;
g,c:char;
b,done1,foundit:boolean;
begin
done1:=FALSE;
reset(xf);
repeat
nl;
sprompt('^4Protocol (^0?^4=^0list^4) : ^3'); mpkey(s);
if (s='?') then begin
nl;
showprots(FALSE,TRUE,FALSE,FALSE);
end else begin
p:=findprot(s,FALSE,TRUE,FALSE,FALSE);
if (p=-99) then print('Invalid entry.') else done1:=TRUE;
end;
until (done1) or (hangup);
dok:=TRUE; kabort:=FALSE;
if (-p in [1,2,3,4,12]) or (p in [1..200]) then
case checkfileratio of
1:begin
nl;
sprint(fstring.unbalance);
nl;
prompt('You have DLed: '+cstr(trunc(thisuser.dk))+'k in '+cstr(thisuser.downloads)+' file');
if thisuser.downloads<>1 then print('s') else nl;
prompt('You have ULed: '+cstr(trunc(thisuser.uk))+'k in '+cstr(thisuser.uploads)+' file');
if thisuser.uploads<>1 then print('s') else nl;
nl;
print(' 1 upload for every '+cstr(systat.dlratio[thisuser.sl])+' downloads must be maintained.');
print(' 1k must be uploaded for every '+cstr(systat.dlkratio[thisuser.sl])+'k downloaded.');
sysoplog('Tried to download while ratio out of balance:');
addtologupdown;
p:=-11;
end;
2:begin
nl;
sprint(fstring.unbalance);
nl;
print('Assuming you download the files already in the batch queue,');
print('your upload/download ratio would be out of balance.');
sysoplog('Tried to add to batch queue while ratio out of balance:');
addtologupdown;
p:=-11;
end;
end;
if (p>=0) then begin seek(xf,p); read(xf,protocol); end;
close(xf);
lastprot:=p;
case p of
-12:ymbadd(fn);
-11:;
-10:begin dok:=FALSE; kabort:=TRUE; end;
(* -4:if (incom) then send(TRUE,TRUE,fn,dok,kabort,FALSE,rte);
-3:if (incom) then send(FALSE,TRUE,fn,dok,kabort,FALSE,rte);
-2:if (incom) then send(FALSE,FALSE,fn,dok,kabort,FALSE,rte);*)
-1:if (not trm) then sendascii(fn);
(* -2:if (not trm) then begin
assign(f,fn);
{$I-} reset(f); {$I+}
if (ioresult<>0) then print('File not found.')
else begin
kabort:=FALSE;
clrscr;
sx:=wherex; sy:=wherey;
window(1,25,80,25);
textcolor(11); textbackground(1);
gotoxy(1,1);
for t:=1 to 80 do write(' ');
gotoxy(1,1);
write('Sending ASCII File '+fn+' -- Please Wait');
textcolor(7); textbackground(0);
window(1,1,80,24);
gotoxy(sx,sy);
repeat
read(f,g);
o(g); write(g);
until (eof(f)) or (kabort);
close(f);
end;
end;*)
else
if (incom) then begin
cp:=bproline1(protocol.dlcmd);
bproline(cp,sqoutsp(fn));
if (useron) then star('Send ready.');
if (useron) then shel(caps(thisuser.name)+' is downloading!') else
shel('Sending file(s)...');
b:=systat.swapshell; systat.swapshell:=FALSE;
pexecbatch(FALSE,'tgtemp2.bat','tgtest2.$$$',start_dir,cp,errlevel);
systat.swapshell:=b;
shel2;
foundit:=FALSE; i:=0;
while ((i<6) and (not foundit)) do begin
inc(i);
if (value(protocol.dlcode[i])=errlevel) then foundit:=TRUE;
end;
dok:=TRUE;
if ((foundit) and (not (xbxferokcode in protocol.xbstat))) then dok:=FALSE;
if ((not foundit) and (xbxferokcode in protocol.xbstat)) then dok:=FALSE;
end;
end;
if (trm) then begin incom:=FALSE; outcom:=FALSE; end;
if (not useron) and (not kabort) then begin
cursoron(FALSE);
setwindow(wind,36,8,80,12,4,0,1);
gotoxy(3,2); tc(14);
if dok then write('Transfer successful.') else
write('Transfer unsuccessful.');
st:=timer;
while (not keypressed) and (tcheck(st,5)) do abeep;
if keypressed then c:=readkey;
removewindow(wind);
cursoron(TRUE);
incom:=FALSE; outcom:=FALSE;
end;
end;
procedure receive1(fn:astr; resumefile:boolean; var dok,kabort,addbatch:boolean);
var cp,nfn,s:astr;
st:real;
filsize:longint;
p,i,t,fno,sx,sy,nof,errlevel:integer;
c:char;
b,done1,foundit:boolean;
begin
done1:=FALSE;
reset(xf);
repeat
nl;
sprompt('^4Protocol (^0?^4=^0list^4) : ^3'); mpkey(s);
if (s='?') then begin
nl;
showprots(TRUE,FALSE,FALSE,resumefile);
end else begin
p:=findprot(s,TRUE,FALSE,FALSE,resumefile);
if (p=-99) then print('Invalid entry.') else done1:=TRUE;
end;
until (done1) or (hangup);
if (not useron) then begin incom:=TRUE; outcom:=TRUE; end;
dok:=TRUE; kabort:=FALSE;
if (p>=0) then begin seek(xf,p); read(xf,protocol); end;
close(xf);
case p of
-12:addbatch:=TRUE;
-11,-10:begin dok:=FALSE; kabort:=TRUE; end;
-1:if (not trm) then recvascii(fn,dok,rte);
else
if (incom) then begin
cp:=bproline1(protocol.ulcmd);
bproline(cp,sqoutsp(fn));
if (useron) then star('Receive ready.');
if (useron) then shel(caps(thisuser.name)+' is uploading!') else
shel('Receiving file(s)...');
b:=systat.swapshell; systat.swapshell:=FALSE;
pexecbatch(FALSE,'tgtemp2.bat','tgtest2.$$$',start_dir,cp,errlevel);
systat.swapshell:=b;
shel2;
foundit:=FALSE; i:=0;
while ((i<6) and (not foundit)) do begin
inc(i);
if (value(protocol.ulcode[i])=errlevel) then foundit:=TRUE;
end;
dok:=TRUE;
if ((foundit) and (not (xbxferokcode in protocol.xbstat))) then dok:=FALSE;
if ((not foundit) and (xbxferokcode in protocol.xbstat)) then dok:=FALSE;
end;
end;
if (not useron) and (not kabort) then begin
cursoron(FALSE);
setwindow(wind,36,8,80,12,4,0,1);
gotoxy(3,2); tc(14);
if (dok) then write('Transfer successful.') else
write('Transfer unsuccessful.');
st:=timer;
while (not keypressed) and (tcheck(st,5)) do abeep;
if (keypressed) then c:=readkey;
removewindow(wind);
cursoron(TRUE);
incom:=FALSE; outcom:=FALSE;
end;
end;
end.
Reference in New Issue View Git Blame Copy Permalink