Jason Aller Floppy Collection/189.img/TCS120S.ZIP/GFILES.PAS

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.