home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Jason Aller Floppy Collection
/
189.img
/
TCS120S.ZIP
/
GFILES.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1989-04-06
|
38KB
|
1,398 lines
{$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
{$M 65500,0,0 }
unit gfiles;
interface
uses crt,dos,turbo3,
gentypes,configrt,modem,statret,gensubs,subs1,windows,subs2,textret,
mailret,userret,flags,mainr1,ansiedit,lineedit,chatstuf,
mainr2,overret1,protocol,mainmenu;
procedure gfilesection;
implementation
procedure gfilesection;
var showit,itsotay,ymodem:boolean;
var gfile:file of gfilerec;
gf:gfilerec;
gfilea:file of gfilearea;
gfa:gfilearea;
curarea:integer;
procedure beepbeep (ok:integer);
begin
delay (500);
write (^B^M);
case ok of
0:write ('Xfer completed!');
1:write ('Xfer Aborted just before EOF!');
2:write ('Xfer Aborted!')
end;
writeln (^G^M)
end;
procedure parse3 (s:lstr; var a,b,c:integer);
var p:integer;
procedure parse1 (var n:integer);
var ns:lstr;
begin
ns[0]:=#0;
while (p<=length(s)) and (s[p] in ['0'..'9']) do begin
ns:=ns+s[p];
p:=p+1
end;
if length(ns)=0
then n:=0
else n:=valu(ns);
if p<length(s) then p:=p+1
end;
begin
p:=1;
parse1 (a);
parse1 (b);
parse1 (c)
end;
function later (d1,t1,d2,t2:sstr):boolean;
var m1,da1,y1,m2,da2,y2:integer;
function latertime (t1,t2:sstr):boolean;
var n1,n2:integer;
begin
latertime:=timeval(t1)>timeval(t2)
end;
begin
parse3 (d1,m1,da1,y1);
parse3 (d2,m2,da2,y2);
if y1=y2
then if m1=m2
then if da1=da2
then later:=timeval(t1) > timeval(t2)
else later:=da1>da2
else later:=m1>m2
else later:=y1>y2
end;
function Numgfiles:integer;
begin
numgfiles:=filesize(gfile)
end;
function NumAreas:integer;
begin
numareas:=filesize (gfilea)
end;
procedure Seekgfile (n:integer);
begin
seek (gfile,n-1)
end;
procedure Seekgfilea (n:integer);
begin
seek (gfilea,n-1)
end;
procedure Assigngf (N:Integer);
begin
close (gfile);
assign (gfile,uploaddir+'gfILE'+strr(n));
end;
function Makearea:boolean;
var num,n:integer;
gfatmp:gfilearea;
begin
makearea:=false;
writestr ('Create Area '+strr(numareas+1)+'? *');
writeln;
if yes then begin
writestr ('Area Name: *');
if length(input)=0 then exit;
gfatmp.Name:=input;
writestr ('Access Level: *');
if length(input)=0 then exit;
gfatmp.Level:=valu(input);
writestr ('Sponsor [CR/'+unam+']:');
if length(input)=0 then input:=unam;
gfatmp.Sponsor:=input;
gfatmp.UpAble:=True;
writestr('Able to Upload to area [CR/Yes]: *');
if length(input)=0 then input:='Y';
if upcase(input[1])<>'Y' then gfatmp.UpAble:=False;
writestr('Upload Directory [CR/'+uploaddir+']: *');
if length(input)=0 then input:=uploaddir;
gfatmp.gfileDir:=input;
Seekgfilea (numareas+1);
write (gfilea,gfatmp);
gfa:=gfatmp;
Curarea:=NumAreas+1;
Assigngf(CurArea);
rewrite (gfile);
writeln ('Area created');
makearea:=true;
writelog (3,6,gfatmp.Name);
end
end;
procedure Opengfile;
var n:integer;
begin
n:=ioresult;
assign (gfilea,uploaddir+'gfileDir');
reset (gfilea);
if ioresult<>0 then begin
close (gfilea);
n:=ioresult;
rewrite (gfilea);
itsotay:=makearea;
end else itsotay:=true;
end;
function getfname (path:lstr; name:mstr):lstr;
var l:lstr;
begin
l:=path;
if length(l)<>0 then
if not (upcase(l[length(l)]) in [':','\'])
then l:=l+'\';
l:=l+name;
getfname:=l;
end;
function getapath:lstr;
var q,r:integer;
f:file;
b:boolean;
p:lstr;
begin
getapath:=gfa.gfiledir;
repeat
writestr ('Upload Path [CR/'+gfa.gfileDir+']:');
if hungupon then exit;
if length(input)=0 then input:=gfa.gfileDir;
p:=input;
if input[length(p)]<>'\' then p:=p+'\';
b:=true;
assign (f,p+'CON');
reset (f);
q:=ioresult;
close (f);
r:=ioresult;
if q<>0 then begin
writestr (' Path does not exist. Create it [y/n]? *');
b:=yes;
if b then begin
mkdir (copy(p,1,length(p)-1));
q:=ioresult;
b:=q=0;
if b then writestr ('Directory created.')
else writestr ('Unable to create directory.')
end
end
until b;
getapath:=p;
end;
procedure fastlistfile (n:integer);
var q:sstr;
begin
seekgfile (n);
read (gfile,gf);
writeln;
ansicolor (urec.statcolor);
tab (strr(n)+'.',5);
ansicolor (urec.regularcolor);
if break then exit;
if exist(getfname(gf.path,gf.fname)) then
tab (streal(gf.filesize),8) else tab ('Offline',8);
if break then exit;
ansicolor (urec.statcolor);
tab (gf.gfiledescr,66);
ansicolor (urec.regularcolor);
if break then exit;
end;
function NoFiles:boolean;
begin
if Numgfiles=0 then begin
nofiles:=true;
writestr (^M'Sorry, No G-Files!')
end else nofiles:=false
end;
procedure FastListgfiles;
var cnt,max,r1,r2,r3:integer;
begin
if nofiles then exit;
writehdr ('File List'^M);
max:=Numgfiles;
thereare (max,'G-File','G-Files');
parserange (max,r1,r2);
if r1=0 then exit;
tab ('No.',5);
tab ('Bytes',8);
tab ('Description',66);
writeln;
r3:=0;
for cnt:=r1 to r2 do begin
r3:=r3+2;
FASTlistfile (cnt);
if break then exit
end;
writeln;
end;
function GetgfileNum (t:mstr):integer;
var n,s:integer;
function SearchforFile (f:sstr):integer;
var cnt:integer;
begin
for cnt:=1 to numgfiles do begin
seekgfile (cnt);
read (gfile,gf);
if match(gf.fname,f) then begin
searchforfile:=cnt;
exit
end
end;
searchforfile:=0
end;
begin
getgfilenum:=0;
if length(input)>1 then input:=copy(input,2,255) else
repeat
writestr ('File Number to '+t+' [?/List]:');
if hungupon or (length(input)=0) then exit;
if input='?' then begin
fastlistgfiles;
input:=''
end
until input<>'';
val (input,n,s);
if s<>0 then begin
n:=searchforfile(input);
if n=0 then begin
writeln ('No such file.');
exit
end
end;
if (n<1) or (n>numgfiles) then writeln ('Invalid number.')
else getgfilenum:=n
end;
procedure AddFile (gf:gfileRec);
begin
Seekgfile (Numgfiles+1);
write (gfile,gf)
end;
function getfsize (filename:anystr):real;
var df:file of byte;
begin
gf.filesize:=-1;
assign (df,filename);
reset (df);
if ioresult<>0 then exit;
getfsize:=longfilesize(df);
close(df)
end;
const beenaborted:boolean=false;
function Aborted:boolean;
begin
if beenaborted then begin
aborted:=true;
exit
end;
aborted:=xpressed or hungupon;
if xpressed then begin
beenaborted:=true;
writeln (^B'New-scan aborted..')
end
end;
procedure NewScan;
var cnt:integer;
first:integer;
newest:boolean;
label notlater;
begin
newest:=false;
beenaborted:=false;
first:=0;
for cnt:=filesize(gfile) downto 1 do begin
Seekgfile (cnt);
read (gfile,gf);
if later (datestr(gf.when),timestr(gf.when),datestr(laston),timestr(laston))
then first:=cnt
else goto notlater
end;
notlater:
if first<>0 then begin
writeln;
writeln (^M'G-File Area: ['^S+gfa.name+^R']');
for cnt:=first to filesize(gfile) do begin
if aborted then exit;
fastlistfile (cnt);
end
end
end;
procedure SetArea (n:integer);
var otay:boolean;
begin
curarea:=n;
otay:=false;
if (n>numareas) or (n<1) then begin
writeln (^B'Invalid Area!');
if issysop then if makearea then setarea (curarea)
else setarea (1)
else setarea (1);
exit
end;
seekgfilea (n);
read (gfilea,gfa);
otay:=(urec.gfLevel>=gfa.Level);
if not otay then
if curarea=1 then error ('Access Level too low!','','')
else begin
reqlevel (gfa.level);
setarea (1);
exit
end;
Assigngf(n);
close (gfile);
reset (gfile);
if ioresult<>0 then rewrite (gfile);
if showit then writeln (^B^M'G-File Area: '^S,gfa.name,^R' ['^S,curarea,^R']');
if showit=false then writeln;
end;
procedure newscanall;
var cnt:integer;
otay:boolean;
begin
writehdr ('New-Scanning, Press [X] to abort.');
if aborted then exit;
for cnt:=1 to filesize(gfilea) do begin
seekgfilea (cnt);
read (gfilea,gfa);
otay:=false;
if urec.gfLevel>=gfa.Level then otay:=true;
if otay then begin
if aborted then exit;
{ showit:=true; }
setarea (cnt);
{ showit:=false; }
if aborted then exit;
newscan;
end;
if aborted then exit
end;
end;
procedure listareas;
var cnt,old:integer;
gfatmp:gfilearea;
begin
writehdr ('Area List');
old:=curarea;
seekgfileA (1);
writeln(^M'Num Level Name');
for cnt:=1 to NumAreas do begin
read (gfilea,gfatmp);
if (urec.level>=gfatmp.Level) then begin
write (^R,cnt:2,'. ['^S);
tab(strr(gfatmp.Level),5);
writeln(^R'] '^S,gfatmp.Name,^R);
if break then begin
setarea(old);
exit;
end;
end;
end;
{ writeln;
setarea(old); }
end;
function GetAreaNum:integer;
var areastr:sstr;
areanum:integer;
begin
getareanum:=0;
if length(input)>1 then areastr:=copy(input,2,255) else
begin
repeat
listareas;
writestr (^M'Area Number [?/List]:');
if input='!' then listareas else areastr:=input
until (input<>'?') or hungupon;
end;
if length(areastr)=0 then exit;
areanum:=valu(areastr);
if (areanum>0) and (areanum<=NumAreas) then getareanum:=areanum
else begin
writestr ('No such Area!');
if issysop then if makearea then getareanum:=numareas
end;
end;
procedure GetArea;
var areanum:integer;
begin
areanum:=getareanum;
if areanum<>0 then SetArea (areanum);
end;
procedure yourgfstatus;
begin
writeln (^B'╒══════════════════════════════════╕');
write ('│ G-File Level: '^S);
tab (strr(urec.gflevel),15);
writeln (^R'│');
write ('│ G-File Uploads: '^S);
tab (strr(urec.gfuploads),15);
writeln (^R'│');
write ('│ G-File Downloads: '^S);
tab (strr(urec.gfdownloads),15);
writeln (^R'│');
if useqr then begin
calcqr;
write (^R'│ Quality Rating: '^S);
tab (strr(qr),15);
writeln (^R'│');
end;
writeln (^B'╘══════════════════════════════════╛');
end;
procedure showgfile (n:integer);
var f:file;
protop,tran,fn:lstr;
b:integer;
ascii,crcmode,ymodem:boolean;
mm,mmmm:minuterec;
extrnproto:char;
begin
ascii:=false;
seekgfile (n);
read (gfile,gf);
if ulvl<0 then exit;
writeln;
if useqr then begin
calcqr;
if (qr<qrlimit) and (ulvl<qrexempt) then begin
writeln ('Your Quality Rating is '^S+strr(qr)+^R'.');
writeln ('That exceeds the limit of '^S+strr(qrlimit)+^R'!');
writeln ('You must get a better QR before you can download.');
exit;
end;
end;
if not exist(getfname(gf.path,gf.fname)) then begin
writeln('File is [Offline]!');
writeln;
exit;
end;
writeln (^S' - G-File Xfer Protocols -'^R);
writeln;
writeln (^R' ['^S'A'^R']-Ascii (Text Capture)');
writeln (^R' ['^S'X'^R']-Xmodem ['^S'Y'^R']-Ymodem ');
writeln (^R' ['^S'Z'^R']-Zmodem ['^S'J'^R']-Jmodem');
writeln (^R' ['^S'L'^R']-Lynx '^S'*'^R'['^S'G'^R']-Ymodem-G');
writeln (^R' ['^S'S'^R']-Super8k ['^S'K'^R']-K9Xmodem');
writeln (^R' ['^S'R'^R']-Zmodem Recovery ['^S'P'^R']-PCPursuit Zmodem');
writeln (^S'*'^R'['^S'O'^R']-Xmodem OvrThrust '^S'*'^R'['^S'1'^R']-Ymodem OvrThrust');
writeln (^S' * = '^R'Registered DSZ required');
writeln;
if hungupon then exit;
protop:='';
writestr ('Protocol [Q/Quit][CR/Ascii]:');
if hungupon then exit;
tran:=input;
if (length(tran)=0) or (upcase(tran[1])='A') then begin
ascii:=true;
extrnproto:='N';
end;
if not ascii then begin
case upcase(tran[1]) of
'X' : ymodem:=false;
'Y' : ymodem:=true;
'Z' : extrnproto:='Z';
'J' : extrnproto:='J';
'L' : extrnproto:='L';
'G' : extrnproto:='G';
'O' : extrnproto:='O';
'1' : extrnproto:='1';
'S' : extrnproto:='S';
'K' : extrnproto:='K';
'R' : extrnproto:='R';
'P' : extrnproto:='P';
'Q' : exit;
end;
end;
fn:=getfname (gf.path,gf.fname);
if (extrnproto='N') and (not ascii) then crcmode:=true;
if tempsysop then begin
ulvl:=regularlevel;
tempsysop:=false;
writeurec;
bottomline
end;
starttimer (mm);
if (extrnproto='N') and (not ascii) then begin
if asciigraphics in urec.config then write ('■') else
write ('*');
writeln (' Send ready');
b:=protocolxfer (true,false,ymodem,fn);
beepbeep (b)
end;
if (extrnproto<>'N') and (not ascii) then begin
if extrnproto='Z' then writeln (^M'Use the -Z option for RLE compression!');
writeln ('■ Send ready');
b:=doext('S',extrnproto,gf.path,gf.fname,baudrate,usecom);
modeminlock:=false;
modemoutlock:=false;
beepbeep (b)
end;
stoptimer (mm);
if ascii then begin
starttimer (mmmm);
writestr('Press [X] to Abort or [CR] to Continue: *');
if upcase(input[1])='X' then exit;
writeln (^M^R'Title: '^S,gf.gfiledescr,
^M^R'Date: '^S,datestr (gf.when),
^M^R'Time: '^S,timestr (gf.when),^M);
printfile (getfname(gf.path,gf.Fname));
urec.gfdownloads:=urec.gfdownloads+1;
writeln (asciidownload);
writeln;
stoptimer (mmmm);
end;
end;
procedure makeasciigfile (filename:anystr);
var t:text;
b:boolean;
yo:integer;
fname:lstr;
begin
assign (t,filename);
rewrite (t);
writeln;
if (asciigraphics in urec.config) then
writeln ('──────────────────────────────────────────────────────────') else
writeln ('----------------------------------------------------------');
writeln ('[Enter G-File now (Echo''d) - Type /S to Save, /A to Abort]');
if (asciigraphics in urec.config) then
writeln ('──────────────────────────────────────────────────────────') else
writeln ('----------------------------------------------------------');
writeln;
repeat
lastprompt:='Continue...'^M;
wordwrap:=true;
getstr (1);
b:=match(input,'/S') or match(input,'/A');
if not b then writeln (t,input)
until b;
textclose (t);
if match(input,'/A') then erase (t);
writelog (3,2,Filename);
end;
procedure uploadgfile;
var tx,t:text;
ascii,crcmode,bbb:boolean;
yo:integer;
fname,tran,protop,fn:lstr;
extrnproto:char;
emmemm:minuterec;
begin
writeln;
crcmode:=false;
ymodem:=false;
if gfa.upable=false then begin
writeln ('Sorry, Uploading is not allowed in this area!');
writeln;
exit;
end;
repeat
writestr ('Enter Upload Filename: *');
if length(input)=0 then exit;
until validfname (input);
gf.fname:=input;
fn:=getfname(gfa.gfiledir,gf.fname);
if not exist(fn) then begin
writestr ('Description: &');
gf.gfiledescr:=input;
assign (tx,fn);
writeln (^S' G-File Xfer Protocols'^R);
writeln;
writeln (^R' ['^S'A'^R']-Ascii (Text Capture)');
writeln (^R' ['^S'X'^R']-Xmodem ['^S'Y'^R']-Ymodem ');
writeln (^R' ['^S'Z'^R']-Zmodem ['^S'J'^R']-Jmodem');
writeln (^R' ['^S'L'^R']-Lynx '^S'*'^R'['^S'G'^R']-Ymodem-G');
writeln (^R' ['^S'S'^R']-Super8k ['^S'K'^R']-K9Xmodem');
writeln (^R' ['^S'R'^R']-Zmodem Recovery ['^S'P'^R']-PCPursuit Zmodem');
writeln (^S'*'^R'['^S'O'^R']-Xmodem OvrThrust '^S'*'^R'['^S'1'^R']-Ymodem OvrThrust');
writeln (^R' ['^S'E'^R']-Lynx Recovery ');
writeln (^S' * = '^R'Registered DSZ required');
writeln;
if hungupon then exit;
protop:='';
writestr ('Protocol [Q/Quit][CR/Ascii]:');
if hungupon then exit;
tran:=input;
if (length(tran)=0) or (upcase(tran[1])='A') then begin
ascii:=true;
extrnproto:='N';
end else ascii:=false;
if not ascii then begin
case upcase(tran[1]) of
'X' : ymodem:=false;
'Y' : ymodem:=true;
'Z' : extrnproto:='Z';
'J' : extrnproto:='J';
'L' : extrnproto:='L';
'G' : extrnproto:='G';
'O' : extrnproto:='O';
'1' : extrnproto:='1';
'S' : extrnproto:='S';
'K' : extrnproto:='K';
'R' : extrnproto:='R';
'P' : extrnproto:='P';
'E' : extrnproto:='E';
'Q' : exit;
end;
end;
if (extrnproto='N') and (not ascii) then crcmode:=true;
if tempsysop then begin
ulvl:=regularlevel;
tempsysop:=false;
writeurec;
bottomline
end;
starttimer (emmemm);
if (extrnproto='N') and (not ascii) then begin
if asciigraphics in urec.config then write ('■') else write ('*');
writeln (' Receive ready');
yo:=protocolxfer (false,crcmode,ymodem,fn);
beepbeep (yo)
end;
if (extrnproto<>'N') and (not ascii) then begin
if extrnproto='Z' then begin
writeln (^M'Zmodem RLE compression being enabled!');
extrnproto:='^';
end;
writeln ('■ Receive ready');
yo:=doext('R',extrnproto,gf.path,gf.fname,baudrate,usecom);
modeminlock:=false;
modemoutlock:=false;
beepbeep (yo)
end;
if (not ascii) and (yo=0) then writelog (3,2,fn);
if (not ascii) and (yo>0) then begin
assign (tx,fn);
erase (tx);
end;
if ascii then begin
assign (t,fn);
rewrite (t);
writeln;
if (asciigraphics in urec.config) then
writeln ('───────────────────────────────────────────────────────') else
writeln ('-------------------------------------------------------');
writeln ('Enter G-File now (Echo''d) - [/S] to Save, [/A] to Abort');
if (asciigraphics in urec.config) then
writeln ('───────────────────────────────────────────────────────') else
writeln ('-------------------------------------------------------');
writeln;
repeat
lastprompt:='Continue...'^M;
wordwrap:=true;
getstr (1);
bbb:=match(input,'/S') or match(input,'/A');
if not bbb then begin
writeln (t,input);
end;
until bbb;
textclose (t);
if match(input,'/A') then erase (t);
writelog (3,2,fn);
end
end else writeln (^M'File exists!'^M);
stoptimer (emmemm);
writeln;
if not exist (fn) then begin
writeln ('Upload Aborted!');
exit;
end else writeln ('Thanks for the upload!');
gf.when:=now;
gf.sentby:=unam;
gf.path:=gfa.gfiledir;
gf.downloaded:=0;
gf.specialfile:=false;
gf.newfile:=true;
gf.filesize:=getfsize (fn);
urec.gfuploads:=urec.gfuploads+1;
seekgfile (numgfiles+1);
write (gfile,gf);
if gfilez>32760 then gfilez:=0;
gfilez:=gfilez+1;
writeln;
writelog (3,10,gf.gfileDescr)
end;
procedure SysopCommands;
var q:integer;
procedure getstr (prompt:mstr; var ss; len:integer);
var a:anystr absolute ss;
begin
writeln (^B^M'Current ',prompt,' is: '^S,a);
buflen:=len;
writestr ('Enter new '+prompt+':');
if length(input)>0 then a:=input;
end;
procedure getint (prompt:mstr; var i:integer);
var q:sstr;
n:integer;
begin
str (i,q);
getstr (prompt,q,5);
n:=valu (q);
if n<>0 then i:=n
end;
procedure getboo (t:lstr; var b:boolean);
var s:sstr;
begin
s:=yesno (b);
getstr (t,s,1);
b:=upcase(s[1])='Y'
end;
procedure RemoveFile (n:integer);
var cnt:integer;
begin
for cnt:=n to numgfiles-1 do begin
seekgfile (cnt+1);
read (gfile,gf);
seekgfile (cnt);
write (gfile,gf)
end;
seekgfile (numgfiles);
truncate (gfile)
end;
procedure Addgfile;
var fn:Anystr;
begin
writestr ('Filename: *');
if length(input)=0 then exit;
gf.fname:=input;
Writestr ('Path [CR/'+gfa.gfileDir+']: *');
if length(input)=0 then Input:=gfa.gfileDir;
gf.path:=input;
begin
fn:=getfname(gf.path,gf.fname);
if not exist(fn) then begin
writestr ('File not found! Enter file now [y/n]? *');
if yes then makeasciigfile(fn)
end;
if not exist(fn) then exit;
end;
writestr ('Description:');
if length(input)=0 then exit;
gf.gfiledescr:=input;
writestr ('Sent by [CR/'+unam+']:');
if length(input)=0 then input:=unam;
gf.sentby:=input;
gf.filesize:=getfsize(fn);
gf.when:=now;
gf.Downloaded:=0;
gf.SpecialFile:=False;
gf.NewFile:=False;
seekgfile (numgfiles+1);
write (gfile,gf);
if gfilez>32760 then gfilez:=0;
gfilez:=gfilez+1;
if urec.lastgfiles>32760 then urec.lastgfiles:=0;
urec.lastgfiles:=urec.lastgfiles+1;
urec.gfuploads:=urec.gfuploads+1;
writelog (3,11,gf.gfiledescr);
writeurec
end;
procedure Editgfile;
var n:integer;
fn:anystr;
begin
n:=getgfilenum('edit');
if n=0 then exit;
seekgfile (n);
read (gfile,gf);
getstr ('Filename',gf.fname,12);
getstr ('Path',gf.path,50);
fn:=Getfname(gf.path,gf.fname);
if not exist (fn) then begin
write (^B^M,fn,' not found!');
writestr (^M'Create new file '+fn+'? *');
if yes then makeasciigfile(fn);
if not exist(fn) then exit;
end else gf.Filesize:=GetFsize(fn);
getstr ('Description',gf.gfileDescr,75);
getstr ('Uploader',gf.Sentby,28);
getboo ('Special File',gf.SpecialFile);
getboo ('New file',gf.NewFile);
seekgfile (n);
write (gfile,gf);
writelog (3,3,gf.gfileDescr);
end;
procedure killgarea;
var gfatmp:gfilearea;
cnt,n:integer;
oldname,newname:sstr;
begin
gfatmp:=gfa;
writestr ('Delete Area #'+strr(curarea)+' ['+gfatmp.Name+']: *');
if not yes then exit;
gfilez:=gfilez-numgfiles;
urec.lastgfiles:=urec.lastgfiles-numgfiles;
if gfilez<0 then gfilez:=0;
if urec.lastgfiles<0 then urec.lastgfiles:=0;
close (gfile);
oldname:=uploaddir+'gfile'+strr(curarea);
assign (gfile,oldname);
erase (gfile);
for cnt:=curarea to NumAreas-1 do begin
newname:=oldname;
oldname:=uploaddir+'gfile'+strr(cnt+1);
assign (gfile,oldname);
rename (gfile,newname);
n:=ioresult;
Seekgfilea (cnt+1);
read (gfilea,gfatmp);
seekgfilea (cnt);
write (gfilea,gfatmp);
end;
seekgfilea (numareas);
truncate (gfilea);
setarea (1)
end;
procedure ModGArea;
var gfatmp:gfilearea;
begin
gfatmp:=gfa;
getstr ('Area Name',gfatmp.Name,80);
getint ('Access Level',gfatmp.Level);
getstr ('Sponsor',gfatmp.Sponsor,30);
getboo ('"Able to upload here"',gfatmp.UpAble);
getstr ('Upload Dir',gfatmp.gfileDir,50);
seekgfilea (curarea);
write (gfilea,gfatmp);
gfa:=gfatmp;
end;
procedure deletegfile;
var cnt,n,anarky:integer;
f:file;
gfn:lstr;
floyd:userrec;
begin
n:=getgfilenum ('Delete');
if n=0 then exit;
seekgfile (n);
read (gfile,gf);
gfn:=getfname(gf.path,gf.fname);
gfn:=upstring(gfn);
writeln;
writehdr ('Delete G-File');
writeln (^R'Filename: '^S,gfn);
writeln (^R'Size: '^S,streal(gf.filesize));
writeln (^R'Description: '^S,gf.gfiledescr);
writeln (^R'Uploader: '^S,gf.sentby);
writeln (^R);
writestr ('Delete this [y/n]? *');
if not yes then exit;
writestr ('Erase Disk File '+gfn+'? *');
if yes then begin
assign (f,getfname(gf.path,gf.fname));
erase (f);
if ioresult<>0 then writestr ('Couldn''t erase File.')
end;
for cnt:=n+1 to numgfiles do begin
seekgfile (cnt);
read (gfile,gf);
seekgfile (cnt-1);
write (gfile,gf)
end;
seekgfile (numgfiles);
truncate (gfile);
if gfilez<0 then gfilez:=0;
gfilez:=gfilez-1;
if urec.lastgfiles<0 then urec.lastgfiles:=0;
urec.lastgfiles:=urec.lastgfiles-1;
writeurec;
writestr ('Remove Upload Credits from uploader [y/n]? *');
if yes then begin
anarky:=lookupuser (gf.sentby);
if anarky<>0 then begin
writeurec;
seek (ufile,anarky);
read (ufile,floyd);
floyd.gfuploads:=floyd.gfuploads-1;
seek (ufile,anarky);
write (ufile,floyd);
readurec
end;
end;
writestr (^M'Deleted.');
writelog (3,4,gf.gfileDescr)
end;
procedure Updategfile;
var n:integer;
begin
n:=GetgfileNum('update');
if n=0 then exit;
seekgfile (n);
read (gfile,gf);
gf.when:=now;
gf.filesize:=getfsize(getfname(gf.path,gf.fname));
seekgfile (n);
write (gfile,gf);
writelog (3,5,gf.gfileDescr)
end;
procedure SortGArea;
var temp,mark,cnt,method:integer;
v1,v2:string[80];
gftmp:gfileRec;
begin
writehdr ('Sort G-Files');
writeln;
writeln ('[0]:Quit');
writeln ('[1]:Description');
writeln ('[2]:Filename');
writeln;
writestr ('Enter method: *');
method:=valu(input[1]);
if method=0 then exit;
mark:=numgfiles-1;
repeat
if mark<>0 then begin
temp:=mark;
mark:=0;
for cnt:=1 to temp do begin
seekgfile (cnt);
read (gfile,gf);
read (gfile,gftmp);
if method=1 then begin
v1:=upstring(gf.gfileDescr);
v2:=upstring(gftmp.gfileDescr);
end else begin
v1:=upstring(gf.fname);
v2:=upstring(gftmp.fname);
end;
if v1>v2 then begin
mark:=cnt;
seekgfile (cnt);
write (gfile,gftmp);
write (gfile,gf)
end
end
end
until mark=0
end;
procedure ReorderGAreas;
var cura,newa:integer;
gfatmp:gfilearea;
f1,f2:file;
fn1,fn2:sstr;
label exit;
begin
writehdr ('Reorder G-File Areas');
writeln (^M'Number of G-File areas: ',numareas:1);
for cura:=0 to numareas-2 do begin
repeat
writestr (^M^J+'New Area #'+strr(cura+1)+' [?/List]:[CR/Quit]:');
if length(input)=0 then goto exit;
if input='?' then begin
listareas;
newa:=-1
end else begin
newa:=valu(input)-1;
if (newa<0) or (newa>=numareas) then begin
writeln ('Not found! Please re-enter...');
newa:=-1
end
end
until (newa>0);
seek (gfilea,cura);
read (gfilea,gfa);
seek (gfilea,newa);
read (gfilea,gfatmp);
seek (gfilea,cura);
write (gfilea,gfatmp);
seek (gfilea,newa);
write (gfilea,gfa);
fn1:=uploaddir+'gfile';
fn2:=fn1+strr(newa+1);
fn1:=fn1+strr(cura+1);
assign (f1,fn1);
assign (f2,fn2);
rename (f1,'Temp$$$$.%%%');
rename (f2,fn1);
rename (f1,fn2)
end;
exit:
setarea (1)
end;
procedure Movegfile;
var an,fn,old:integer;
newfilesam,sambam,filesam,wangbang:anystr;
darn:file;
gftmp:gfileRec;
begin
fn:=GetgfileNum ('move');
old:=curarea;
if fn=0 then exit;
input:='';
an:=GetAreaNum;
if an=0 then exit;
Seekgfile (fn);
read (gfile,gftmp);
removefile (fn);
writestr('Physically move the file to correct area? *');
write ('Moving...');
filesam:=Getfname(gftmp.path,gftmp.fname);
sambam:=gftmp.path;
setarea(an);
if (sambam<>gfa.gfileDir) then if yes then begin
gftmp.path:=gfa.gfileDir;
newfilesam:=Getfname(gftmp.path,gftmp.fname);
exec('Copy',' '+filesam+' '+newfilesam+' >temp');
wangbang:=filesam;
assign(darn,wangbang);
if exist(newfilesam) then erase (darn) else begin
gftmp.path:=sambam;
writeln('Uh oh... Bad error!');
end;
end;
setarea (An);
Addfile (gftmp);
setarea (old);
writeln (^B'Done.')
end;
procedure getpathname (fname:lstr; var path:lstr; var name:sstr);
var p:integer;
begin
path:='';
repeat
p:=pos('\',fname);
if p<>0 then begin
path:=path+copy(fname,1,p);
fname:=copy(fname,p+1,255)
end
until p=0;
name:=fname
end;
procedure displayfile (var ffinfo:searchrec);
var a:integer;
begin
a:=ffinfo.attr;
if (a and 8)=8 then exit;
tab (ffinfo.name,13);
if (a and 16)=16
then write ('Directory')
else write (ffinfo.size);
if (a and 1)=1 then write (' <read-only>');
if (a and 2)=2 then write (' <hidden>');
if (a and 4)=4 then write (' <system>');
writeln
end;
procedure getfsize (var g:gfilerec);
var df:file of byte;
begin
g.filesize:=-1;
assign (df,getfname(g.path,g.fname));
reset (df);
if ioresult<>0 then exit;
g.filesize:=filesize(df);
close(df)
end;
procedure addresidentgfile (fname:lstr);
var g:gfilerec;
fn:anystr;
begin
getpathname (fname,g.path,g.fname);
getfsize(g);
if g.filesize=-1 then begin
writeln ('File can''t be opened!');
exit
end;
writestr ('Description: &');
g.gfiledescr:=input;
getfsize(g);
g.when:=now;
g.sentby:=unam;
g.downloaded:=0;
g.specialfile:=False;
g.newfile:=False;
seekgfile (numgfiles+1);
write (gfile,g);
gfilez:=gfilez+1;
writeln;
writelog (3,11,g.gfiledescr)
end;
procedure addmultiplegfiles;
var spath,pathpart:lstr;
dummy:sstr;
f:file;
ffinfo:searchrec;
begin
if ulvl<sysoplevel then begin
writeln (
'Sorry, you may not add resident files without true sysop access!');
exit
end;
writehdr ('Add Resident G-Files By Wildcard');
writestr ('Search path/wildcard:');
if length(input)=0 then exit;
spath:=input;
if spath[length(spath)]='\' then dec(spath[0]);
assign (f,spath+'\con');
reset (f);
if ioresult=0 then begin
close (f);
spath:=spath+'\*.*'
end;
getpathname (spath,pathpart,dummy);
findfirst (spath,$17,ffinfo);
if doserror<>0
then writeln ('No files found!')
else
while doserror=0 do begin
writeln;
displayfile (ffinfo);
writestr ('Add this file [Y/N/X]? *');
if yes
then addresidentgfile (getfname(pathpart,ffinfo.name))
else if (length(input)>0) and (upcase(input[1])='X')
then exit;
findnext (ffinfo)
end
end;
function defaultdrive:byte;
var r:registers;
begin
r.ah:=$19;
intr ($21,r);
defaultdrive:=r.al+1
end;
function unsigned (i:integer):real;
begin
if i>=0
then unsigned:=i
else unsigned:=65536.0+i
end;
procedure writefreespace (path:lstr);
var drive:byte;
r:registers;
csize,free,total:real;
begin
r.ah:=$36;
r.dl:=ord(upcase(path[1]))-64;
intr ($21,r);
if r.ax=-1 then begin
writeln ('Invalid drive');
exit
end;
csize:=unsigned(r.ax)*unsigned(r.cx);
free:=csize*unsigned(r.bx);
total:=csize*unsigned(r.dx);
free:=free/1024;
total:=total/1024;
writeln (free:0:0,'k out of ',total:0:0,'k')
end;
procedure directory;
var r:registers;
ffinfo:searchrec;
tpath:anystr;
b:byte;
cnt:integer;
begin
getdir (defaultdrive,tpath);
if tpath[length(tpath)]<>'\' then tpath:=tpath+'\';
tpath:=tpath+'*.*';
writestr ('Path/Wildcard [CR for '+tpath+']:');
writeln (^M);
if length(input)<>0 then tpath:=input;
writelog (16,10,tpath);
findfirst (chr(defaultdrive+64)+':\*.*',8,ffinfo);
if doserror<>0
then writeln ('No volume label'^M)
else writeln ('Volume label: ',ffinfo.name,^M);
findfirst (tpath,$17,ffinfo);
if doserror<>0 then writeln ('No files found.') else begin
cnt:=0;
while doserror=0 do begin
cnt:=cnt+1;
if not break then displayfile (ffinfo);
findnext (ffinfo)
end;
writeln (^B^M'Total Files: ',cnt)
end;
write ('Free Disk Space: ');
writefreespace (tpath)
end;
begin
if not issysop then begin
reqlevel (sysoplevel);
exit
end;
repeat
q:=menu ('G-File Sysop','SGFILE','QACDUKRMSOW@F`');
case q of
2:addgfile;
3:editgfile;
4:deletegfile;
5:updategfile;
6:killgarea;
7:modgarea;
8:movegfile;
9:Sortgarea;
10:reordergareas;
11:addmultiplegfiles;
12:directory;
13:begin
writestr ('Access Code: *');
if not match (input,'G;G') then exit;
writeln;
writeln ('gfilez:',gfilez);
writeln ('urec.lastgfiles:',urec.lastgfiles);
writestr ('set gfilez/urec.lastgfiles to 0 [y/n]? *');
if yes then begin
gfilez:=0;
urec.lastgfiles:=0;
end;
writestr ('urec.gfuploads ('+strr(urec.gfuploads)+'): &');
if length(input)>0 then urec.gfuploads:=valu(input);
writeurec;
end;
end
until hungupon or (q=1)
end;
var prompt:lstr;
n:integer;
k:char;
q1:mstr;
a:arearec;
ms:boolean;
dammit:boolean;
q:integer;
x1,x2,x3,zxcv1,zxcv2:integer;
y1,y2,y3:real;
begin
dammit:=false;
showit:=true;
writehdr ('G-Files Section');
writeln;
itsotay:=false;
opengfile;
if not itsotay then exit;
seekgfilea(1);
read (gfilea,gfa);
if (urec.gfLevel<gfa.Level) then begin
writeln('You don''t have access to the G-Files Section.');
exit;
end;
x1:=urec.nbu;
x2:=urec.numon;
if x1<1 then x1:=1;
if x2<1 then x2:=1;
y1:=int(x1);
y2:=int(x2);
y1:=y1;
y2:=y2;
y3:=y1/y2;
y3:=y3*100;
x3:=trunc(y3);
write (^R'Required Post/Call Ratio: ['^S);
for zxcv1:=1 to 3-(length(strr(gfpcr))) do write (' ');
write (strr(gfpcr));
writeln ('%'^R']');
write (^R'Your Post/Call Ratio: ['^S);
for zxcv2:=1 to 3-(length(strr(x3))) do write (' ');
write (strr(x3));
writeln ('%'^R']');
writeln;
write (^R'PCR Status: ['^S);
if ulvl>=pcrexempt then write ('Exempt from PCR.') else
if (x3<gfpcr) and (ulvl<pcrexempt) then write ('PCR too low!') else
if (x3>=gfpcr) and (ulvl<pcrexempt) then write ('Passed PCR check.');
writeln (^R']');
writeln;
if (x3<gfpcr) and (ulvl<pcrexempt) then begin
writeln (^B^R'Your Posts-per-Call Ratio is too low!');
writeln ('Go post a message or two.');
close (gfile);
close (gfilea);
exit;
end;
yourgfstatus;
setarea(1);
repeat
prompt:='';
q:=menu ('G-Files Command','GFILE','QU%FAYNVDLG');
case q of
1:begin
close(gfile);
close(gfilea);
end;
2:uploadgfile;
3:sysopcommands;
4:fastlistgfiles;
5:getarea;
6:yourgfstatus;
7:newscanall;
8:newscan;
9:begin
n:=getgfilenum ('Download');
if n>0 then showgfile(n);
end;
10:fastlistgfiles;
11:offtcs;
end;
until hungupon or (q=1);
end;
begin
end.