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

Pascal/Delphi Source File | 1989-04-06 | 63KB | 2,252 lines

{$R-,S-,I-,D-,F+,V-,B-,N-,O+ }
{$M 65500,0,0 }

unit filexfer;

interface

uses crt,dos,
     gentypes,configrt,modem,statret,gensubs,subs1,subs2,windows,
     userret,mainr1,mainr2,overret1,protocol,mainmenu,subs3,textret;

procedure udsection;

implementation

procedure udsection;

var ud:udrec;
  { area:arearec; }
    curarea:integer;
    offliney,vcr:boolean;
    validprotos:set of char;
    xtype:char;

  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;

  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 seekafile (n:integer);
  begin
    seek (afile,n-1)
  end;

  function numareas:integer;
  begin
    numareas:=filesize (afile)
  end;

  procedure seekudfile (n:integer);
  begin
    seek (udfile,n-1)
  end;

  function numuds:integer;
  begin
    numuds:=filesize (udfile)
  end;

  procedure assignud;
  begin
    close (udfile);
    assign (udfile,'AREA'+strr(curarea))
  end;

  function sponsoron:boolean;
  begin
    sponsoron:=match(area.sponsor,unam) or issysop
  end;

  function getapath:lstr;
  var q,r:integer;
      f:file;
      b:boolean;
      p:lstr;
  begin
    getapath:=area.xmodemdir;
    if ulvl<sysoplevel then exit;
    repeat
      writestr ('Upload Path [CR/'+area.xmodemdir+']:');
      if hungupon then exit;
      if length(input)=0 then input:=area.xmodemdir;
      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 doesn''t 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;

  function makearea:boolean;
  var num,n:integer;
      a:arearec;
  begin
    makearea:=false;
    num:=numareas+1;
    n:=numareas;
    writestr ('Create Area '+strr(num)+' [y/n]? *');
    if yes then begin
      writestr ('Area Name: &');
      if length(input)=0 then exit;
      a.name:=input;
      writestr ('Access Level:');
      if length(input)=0 then exit;
      a.level:=valu(input);
      writestr ('Sponsor [CR/'+unam+']:');
      if length(input)=0 then input:=unam;
      a.sponsor:=input;
    { writestr ('Entry Password [CR/None]:');
      if length(input)=0 then a.areapw:='' else
      a.areapw:=input; }
      writestr ('Able to Upload into this area? [CR/Yes]:');
      if (length(input)=0) or (upcase(input[1])='Y') then
      a.upload:=true else a.upload:=false;
      writestr ('Able to Download from this area? [CR/Yes]:');
      if (length(input)=0) or (upcase(input[1])='Y') then
      a.download:=true else a.download:=false;
      a.xmodemdir:=getapath;
      seekafile (num);
      write (afile,a);
      area:=a;
      curarea:=num;
      assignud;
      rewrite (udfile);
      writeln ('Area created');
      makearea:=true;
      writelog (15,4,a.name)
    end
  end;

  procedure setarea (n:integer);

    procedure nosucharea;
    begin
    { writeln (^B'No such area: ',n,'!'); }
      writeln (^B'No such area!')
    end;

  begin
    curarea:=n;
    if (n>numareas) or (n<1) then begin
      nosucharea;
      if issysop
        then if makearea
          then setarea (curarea)
          else setarea (1)
        else setarea (1);
      exit
    end;
    seekafile (n);
    read (afile,area);
    if (urec.udlevel<area.level) and (not issysop)
      then if curarea=1
        then error ('User can''t access first area','','')
        else
          begin
            nosucharea;
            setarea (1);
            exit
          end;
   { if length(area.areapw)>0 then begin
     writeln;
     writestr ('Entry Password:');
     if length(input)=0 then exit;
     if not match(input,area.areapw) then exit;
    end; }
    assignud;
    close (udfile);
    reset (udfile);
    if ioresult<>0 then rewrite (udfile);
    writeln (^B^M'Area: '^S,area.name,^R' ['^S,curarea,^R']');
    { if sponsoron then writeln (^S'%: '^R'Sponsor Commands'); }
    writeln
  end;

  procedure listareas;
  var a:arearec;
      cnt,gaybee:integer;
  begin
   if exist (textfiledir+'Filearea.BBS') then
   printfile (textfiledir+'Filearea.BBS') else
   begin
    writehdr ('File Area List');
    seekafile (1);
    writeln ('##. [Level] [Name]'^M);
    for cnt:=1 to numareas do begin
      read (afile,a);
      if a.level<=urec.udlevel
        then begin
        write (^R,cnt:2,'. [');
        write (^S,a.level);
        for gaybee:=1 to (5-(length(strr(a.level)))) do
         write (' ');
        write (^R'] ['^S,a.name,^R']'^M);
        end;
      if break then exit
    end
   end
  end;

  function getareanum:integer;
  var areastr:sstr;
      areanum:integer;
  begin
    getareanum:=0;
    if length(input)>1
      then areastr:=copy(input,2,255)
      else begin
        listareas;
        repeat
          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;

  function getfname (path:lstr; name:mstr):lstr;
  var l:lstr;
  begin
    l:=path;
    if length(l)<>0
      then if not (l[length(l)] in [':','\'])
        then l:=l+'\';
    l:=l+name;
    getfname:=l
  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 listfile (n:integer; extended:boolean);
  var ud:udrec;
      q:sstr;
      a,b,c,ed:string;
  begin
    seekudfile (n);
    read (udfile,ud);
    ansicolor (urec.statcolor);
    tab (strr(n)+'.',4);
    ansicolor (urec.promptcolor);
    tab (ud.filename,14);
    ansicolor (urec.inputcolor);
    if ud.newfile
      then write ('[New]  ')
      else if ud.specialfile
        then write ('[Ask]  ')
        else if ud.points>0
          then tab (strr(ud.points),7)
          else write ('[Free] ');
    ansicolor (urec.regularcolor);
    if exist (getfname(ud.path,ud.filename)) then tab (strlong(ud.filesize),10) else
     write ('[Offline] ');
    ansicolor (urec.statcolor);
    writeln (ud.descrip);
    ansicolor (urec.regularcolor);
    if break or (not extended) then exit;
    write (^R'    ');
    tab (datestr(ud.when),19);
    ansicolor (urec.promptcolor);
    tab (strr(ud.downloaded)+' D/L''s',13);
    ansicolor (urec.inputcolor);
    writeln (ud.sentby);
    a:=copy (ud.extdesc,1,80);
    ansicolor (urec.statcolor);
    writeln (a);
    if length(ud.extdesc)>80 then begin
     b:=copy (ud.extdesc,81,80);
     ansicolor (urec.statcolor);
     writeln (b);
    end;
    if length(ud.extdesc)>160 then begin
     c:=copy (ud.extdesc,161,80);
     ansicolor (urec.statcolor);
     writeln (c);
    end;
    ansicolor (urec.regularcolor);
  end;

  function nofiles:boolean;
  begin
    if numuds=0 then begin
      nofiles:=true;
      writestr (^M'Sorry, no files!')
    end else nofiles:=false
  end;

  procedure listfiles (extended:boolean);
  var cnt,max,r1,r2:integer;
  const extendedstr:array[false..true] of string[9]=('','Extended ');
  begin
    if nofiles then exit;
    writehdr (extendedstr[extended]+'File List');
    max:=numuds;
    thereare (max,'File','Files');
    parserange (max,r1,r2);
    if r1=0 then exit;
    writeln (^S'#.'^P'  Filename'^U'      Points '^R'Size      '^S'Description'^R);
    if (asciigraphics in urec.config) then
     writeln ('───────────────────────────────────────────────────────────────────────────────')
    else
     writeln ('-------------------------------------------------------------------------------');
    for cnt:=r1 to r2 do begin
      listfile (cnt,extended);
      if break then exit
    end
  end;

  function searchforfile (f:sstr):integer;
  var ud:udrec;
      cnt:integer;
  begin
    for cnt:=1 to numuds do begin
      seekudfile (cnt);
      read (udfile,ud);
      if match(ud.filename,f) then begin
        searchforfile:=cnt;
        exit
      end
    end;
    searchforfile:=0
  end;

  function getfilenum (t:mstr):integer;
  var n,s:integer;
  begin
    getfilenum:=0;
    if length(input)>1 then input:=copy(input,2,255) else
      repeat
        writestr ('File Name/Number to '+t+' [?/List]:');
        if hungupon or (length(input)=0) then exit;
        if input='?' then begin
          listfiles (false);
          input:=''
        end
      until input<>'';
    val (input,n,s);
    if s<>0 then begin
      n:=searchforfile(input);
      if n=0 then begin
        writeln ('File not found.');
        exit
      end
    end;
    if (n<1) or (n>numuds)
      then writeln ('File number out of range!')
      else getfilenum:=n
  end;

  function allowxfer:boolean;
  var cnt:baudratetype;
      k:char;
  begin
    allowxfer:=false;
   { if not carrier then begin
      writeln ('You may only transfer from remote!');
      exit
    end; }
    for cnt:=firstbaud to lastbaud do
      if baudrate=baudarray[cnt]
        then if not (cnt in downloadrates)
          then begin
            writeln ('Sorry, File Transfer is not allowed at ',baudrate,' Baud!');
            exit
          end;
    if parity then begin
      writeln ('Please select NO parity and press [Return]:');
      parity:=false;
      setparam (usecom,baudrate,parity);
      repeat
        k:=getchar;
        if hungupon then exit
      until k in [#13,#141];
      if k=#141 then begin
        parity:=true;
        setparam (usecom,baudrate,parity);
        writeln ('You did not turn off parity.  Transfer aborted.');
        exit
      end
    end;
    allowxfer:=true
  end;

  procedure addfile (ud:udrec);
  begin
    seekudfile (numuds+1);
    write (udfile,ud)
  end;

  procedure getfsize (var ud:udrec);
  var df:file of byte;
  begin
    ud.filesize:=-1;
    assign (df,getfname(ud.path,ud.filename));
    reset (df);
    if ioresult<>0 then exit;
    ud.filesize:=filesize(df);
    close(df)
  end;

  function wildcardmatch (w,f:sstr):boolean;
  var a,b:sstr;

    procedure transform (t:sstr; var q:sstr);
    var p:integer;

      procedure filluntil (k:char; n:integer);
      begin
        while length(q)<n do q:=q+k
      end;

      procedure dopart (mx:integer);
      var k:char;
      begin
        repeat
          if p>length(t)
            then k:='.'
            else k:=t[p];
          p:=p+1;
          case k of
            '.':begin
                  filluntil (' ',mx);
                  exit
                end;
            '*':filluntil ('?',mx);
            else if length(q)<mx then q:=q+k
          end
        until 0=1
      end;

    begin
      p:=1;
      q:='';
      dopart (8);
      dopart (11)
    end;

    function theymatch:boolean;
    var cnt:integer;
    begin
      theymatch:=false;
      for cnt:=1 to 11 do
        if (a[cnt]<>'?') and (b[cnt]<>'?') and
           (upcase(a[cnt])<>upcase(b[cnt])) then exit;
      theymatch:=true
    end;

  begin
    transform (w,a);
    transform (f,b);
    wildcardmatch:=theymatch
  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'File New-Scan Aborted!')
    end
  end;

  procedure getstring (t:lstr; var m);
  var q:lstr absolute m;
      mm:lstr;
  begin
    writeln ('Old ',t,': ',q);
    writestr ('Enter new '+t+' [CR/no change]:');
    mm:=input;
    if length(mm)<>0 then q:=mm;
    writeln
  end;

  procedure getint (t:lstr; var i:integer);
  var s:sstr;
  begin
    s:=strr(i);
    getstring (t,s);
    i:=valu(s)
  end;

  procedure getboo (t:lstr; var b:boolean);
  var s:sstr;
  begin
    s:=yesno (b);
    getstring (t,s);
    b:=upcase(s[1])='Y'
  end;

  procedure removefile (n:integer);
  var cnt:integer;
  begin
    for cnt:=n to numuds-1 do begin
      seekudfile (cnt+1);
      read (udfile,ud);
      seekudfile (cnt);
      write (udfile,ud)
    end;
    seekudfile (numuds);
    truncate (udfile)
  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;

  function defaultdrive:byte;
  var r:registers;
  begin
    r.ah:=$19;
    intr ($21,r);
    defaultdrive:=r.al+1
  end;

  procedure directory;
  var r:registers;
      ffinfo:searchrec;
      tpath:anystr;
      b:byte;
      cnt:integer;
  begin
    { getdir (defaultdrive,tpath); }
    tpath:=area.xmodemdir;
    if tpath[length(tpath)]<>'\' then tpath:=tpath+'\';
    tpath:=tpath+'*.*';
    writestr ('Path/Wildcard [CR/'+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;

  procedure listarchive;
  var n:integer;
      ud:udrec;
      f:file of byte;
      fname:lstr;
      b,p:byte;
      sg:boolean;
      size:longint;
      sussuh:sstr;
      ock:char;

    function getsize:longint;
    var x:longint;
        b:array [1..4] of byte absolute x;
        cnt:integer;
    begin
      for cnt:=1 to 4 do read (f,b[cnt]);
      getsize:=x
    end;

    procedure badarchive;
    begin
      writeln (^M'That file isn''t an archive!');
      close (f);
      exit
    end;

  begin
    if nofiles then exit;
    n:=getfilenum('List');
    if n=0 then exit;
    seekudfile (n);
    read (udfile,ud);
    fname:=getfname(ud.path,ud.filename);
    assign (f,fname);
    reset (f);
    iocode:=ioresult;
    if iocode<>0 then begin
      fileerror ('LISTARCHIVE',fname);
      exit
    end;
    if filesize(f)<32 then begin
      badarchive;
      exit
    end;
    p:=pos ('.',ud.filename);
    sussuh:=copy (ud.filename,p+1,3);
    sussuh:=upstring(sussuh);
    close (f);
    writehdr ('ARC/PAK/ZIP File List');
    writeln;
    writeln (^R'Archive Type [Automatically Detected]:');
    write (^R'-> '^S);
    if sussuh='ARC' then writeln ('PKARC/PKPAK') else
    if sussuh='PAK' then writeln ('PAK') else
    if sussuh='ZIP' then writeln ('PKZIP') else
    if sussuh='ZOO' then writeln ('ZOO');
    if sussuh='ZOO' then begin
     writeln (^R);
     writeln ('TCS does not support ZOO archive viewing. Sorry.');
     exit;
    end;
    if (sussuh<>'ARC') and (sussuh<>'PAK') and (sussuh<>'ZIP')  then begin
     writeln ('None!');
     writeln;
     writeln (^R'This file does not seem to be an archive of the ARC, PAK, or ZIP type.');
     writestr ('Would you care to manually select the archive type [y/n]? *');
     if yes then repeat
      writeln (^R'[1]: PKARC/PKPAK');
      writeln (^R'[2]: PAK');
      writeln (^R'[3]: PKZIP');
      writeln (^R'[Q]: Quit');
      writeln;
      writestr ('Selection:');
      ock:=upcase(input[1]);
      if ock='1' then sussuh:='ARC' else
      if ock='2' then sussuh:='PAK' else
      if ock='3' then sussuh:='ZIP';
     until ock in ['Q','1','2','3'];
    end;
    writeln;
    writeln ('Please hold...');
    writeln;
    if sussuh='ARC' then arcview (fname) else
    if sussuh='PAK' then pakview (fname) else
    if sussuh='ZIP' then zipview (fname);
  end;

procedure requestfile;
var t:text;
    me:message;
    m:mailrec;
begin
  if hungupon then exit;
  writestr (^M^J+'Filename to Request: *');
  if length(input)=0 then exit;
  writeln (^M^J+'Enter a Message regarding the File Request:');
  delay (1000);
  titlestr:='File Request: '+input;
  sendstr:='Sysop';
  m.line:=editor (me,false,'File Request: '+input);
  sendstr:='';
  if m.line<0 then exit;
  m.anon:=false;
  m.title:=titlestr;
  m.sentby:=unam;
  m.when:=now;
  addfeedback (m);
end;

  function isdsz (var thegog:char):boolean;
  begin
   isdsz:=thegog in ['Z','G','O','1','R','P'];
  end;

  function issuperk (var whoasux:char):boolean;
  begin
   issuperk:=whoasux in ['S','E','K','W'];
  end;

  procedure download (autoselect:integer);
  var totaltime:sstr;
      num,fsize,actualsize,mins,secs,i,b,dsziactualsize,realtime:integer;
      ud:udrec;
      fname,tcsrulez,protop,tran:lstr;
      ymodem:boolean;
      f:file;
      m:sstr;
      extrnproto:char;
      n:text;
      ok:boolean;
  begin
    if not allowxfer then exit;
    if nofiles then exit;
    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 (area.download=false) then begin
     writeln;
     writeln ('Sorry, downloading is not allowed from this area!');
     writeln;
     exit;
    end;
    if autoselect=0
      then num:=getfilenum('Download')
      else num:=autoselect;
    if num=0 then exit;
    writeln;
    seekudfile (num);
    read (udfile,ud);
    ok:=checkok (ud);
    if not ok then exit;
    ymodem:=false;
    extrnproto:=' ';
    writeln;
    writeln (^S'       - TCS Xfer Protocols -');
    writeln;
    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:='';
    protop:='Protocol [Q/Quit][CR/';
    if upcase(urec.defproto) in validprotos then
    protop:=protop+upcase(urec.defproto) else
    protop:=protop+'Z';
    protop:=protop+']:';
    writestr (protop);
    if hungupon then exit;
    tran:=input;
    if length(tran)=0 then begin
     if upcase (urec.defproto) in validprotos then
     tran[1]:=urec.defproto else tran[1]:='Z';
    end;
    case upcase(tran[1]) of
     'X' : begin
            ymodem:=false;
            extrnproto:='N';
           end;
     'Y' : begin
            ymodem:=true;
            extrnproto:='N';
           end;
     '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;
    fname:=getfname(ud.path,ud.filename);
    assign (f,fname);
    reset (f);
    iocode:=ioresult;
    if iocode<>0 then
      begin
        fileerror ('DOWNLOAD',fname);
        exit
      end;
    fsize:=filesize(f);
    actualsize:=fsize;
    close (f);
    totaltime:=minstr(fsize);
   {if baudrate=9600 then mins:=valu(copy(totaltime,1,pos(':',totaltime)-1 div 8));
    if baudrate=2400 then mins:=valu(copy(totaltime,1,pos(':',totaltime)-1 div 2));
    if baudrate=1200 then mins:=valu(copy(totaltime,1,pos(':',totaltime)-1));
    if baudrate=300 then mins:=valu(copy(totaltime,1,pos(':',totaltime)-1 *4));}
    mins:=valu(copy(totaltime,1,pos(':',totaltime)-1));
    secs:=valu(copy(totaltime,pos(':',totaltime)+1,2));
    realtime:=mins;
    if secs<>0 then realtime:=mins+(secs div 60);
    if mins=0 then mins:=1;
  { mins:=valu(copy(totaltime,1,pos(':',totaltime)-1)); }
    if ((mins>timeleft) and (not sponsoron)) then begin
      writestr ('Sorry, you don''t have enough time left!');
      mins:=-5;
      exit
    end;
    if (mins-5>timetillevent) then begin
      writestr ('Sorry, the timed event is coming up too soon!');
      mins:=-5;
      exit
    end;
    if (ansigraphics in urec.config) then write (#27+'[2J') else write (^L);
    writeln (^B);
    writeln (^R'┌─────────────────────────────────────┐');
    write (^R'│ Filename:       '^S);
    tab (ud.filename,20);
    writeln (^R'│');
    write (^R'│ Uploaded by:    '^S);
    tab (ud.sentby,20);
    writeln (^R'│');
    write (^R'│ Downloaded:     '^S);
    tcsrulez:='';
    tcsrulez:=strr(ud.downloaded)+' time';
    if (ud.downloaded<>1) then tcsrulez:=tcsrulez+'s';
    tab (tcsrulez,20);
    writeln (^R'│');
    if ymodem then fsize:=(fsize+7) div 8;
    if fsize=0 then fsize:=1;
    write (^R'│ Blocks to send: '^S);
    tab (strr(fsize),20);
    writeln (^R'│');
    write (^R'│ Transfer Time:  '^S);
    tab (totaltime,20);
    writeln (^R'│');
    writeln (^R'├─────────────────────────────────────┤');
    writeln (^R'│  Hit ['^S'Ctrl-X'^R'] a few times to Abort  │');
    writeln (^R'└─────────────────────────────────────┘');
    writeln (usr,^M^M'[-File Xfer Status-]');
    writeln (usr,'[User '+unam+' Downloading '+ud.filename+' at ',baudrate,' Baud]');
    writeln (usr,'[User D/L: ',urec.downloads,' downloads, '+streal(urec.downk)+
    ' bytes] [User U/L: ',urec.uploads,' uploads, '+streal(urec.upk)+' bytes]'^M);
    if extrnproto='N' then begin
      b:=protocolxfer (true,false,ymodem,fname);
      beepbeep (b)
    end;
    if extrnproto<>'N' then begin
      b:=doext('S',extrnproto,ud.path,ud.filename,baudrate,usecom);
      if b<>0 then b:=2;
      modeminlock:=false;
      beepbeep (b)
    end;
    if isdsz (extrnproto) then begin
      xtype:=checkdszlog (getfname(ud.path,ud.filename));
      if (upcase(xtype)='Q') and (leechzmodem) then
      begin
       possiblelzm (ud.points);
       b:=2;
      end;
      if (upcase(xtype)='E') or (upcase(xtype)='L') then b:=2;
      end;
    if issuperk (extrnproto) then begin
    { ztype:=checksklog (getfname(ud.path,ud.filename));
      if (upcase(ztype)='R') and (leechzmodem) then
      begin
       possiblelzm (ud.points);
       b:=2;
      end;
      if (upcase(ztype)='E') or (upcase(ztype)='L') then b:=2; }
    end;
      if (b=0) or (b=1) then begin
      writelog (15,1,fname);
      ud.downloaded:=ud.downloaded+1;
      urec.downloads:=urec.downloads+1;
      urec.downk:=urec.downk+ud.filesize;
      seekudfile (num);
      write (udfile,ud);
    { if (ud.points>0) and (not sponsoron) then } begin
       write ('File Pts. you have ');
       if (asciigraphics in urec.config) then write ('─') else write ('-');
       writeln ('> '^S,urec.udpoints,^R);
       urec.udpoints:=urec.udpoints-ud.points;
       write ('Cost of File ');
       if ascii then
       write ('───────') else
       write ('-------');
       writeln ('> '^S,ud.points,^R);
       write ('                      ');
       if (asciigraphics in urec.config) then
       writeln ('───────') else
       writeln ('-------');
       write ('You now have ');
       if (asciigraphics in urec.config) then
       write ('───────') else
       write ('-------');
       writeln ('> '^S,urec.udpoints,^R^M);
      end;
      writeurec
    end;
   if b=2 then begin

   end;
  end;

  procedure typefile;
  var num:integer;
      ud:udrec;
      fname:lstr;
      f:text;
      k:char;
  begin
    if nofiles then exit;
    num:=getfilenum('type');
    if num=0 then exit;
    writeln;
    seekudfile (num);
    read (udfile,ud);
    if (not sponsoron) and (ud.points>urec.udpoints) then begin
      writeln ('Sorry, that file requires ',ud.points,' points.');
      exit
    end;
    if (ud.newfile) and (not sponsoron) then begin
      writeln ('Sorry, that is a new file and must be validated.');
      exit
    end;
    if (ud.specialfile) and (not sponsoron) then begin
      writeln ('Sorry, downloading that file requires special permission.');
      exit
    end;
    if (length(ud.dlpw)>0) and (filepw) then begin
     writeln;
     writestr ('File Password:');
     if length(input)=0 then exit else
     if not match(input,ud.dlpw) then exit;
    end;
    if tempsysop then begin
      ulvl:=regularlevel;
      tempsysop:=false;
      writeurec;
      bottomline
    end;
    fname:=getfname(ud.path,ud.filename);
    assign (f,fname);
    reset (f);
    iocode:=ioresult;
    if iocode<>0 then
      begin
        fileerror ('TYPEFILE',fname);
        exit
      end;
    writeln (^B^M'Filename:       '^S,ud.filename);
    writeln ('Uploaded by:    '^S,ud.sentby);
    if (ud.points>0) and (not sponsoron) then begin
      write (^B^M'NOTE: When the transfer begins, you ',
               ^M'      will be charged ',ud.points,' point');
      if ud.points<>1 then write ('s');
      writeln ('!')
    end;
    writeln (^B^M'Press any key to begin the transfer,',
               ^M'or [Ctrl-X] to abort...'^M);
    k:=waitforchar;
    if (k=^X) or (upcase(k)='X') then begin
      textclose (f);
      writeln (^B^M'Aborted!');
      exit
    end;
    while not (eof(f) or break) do begin
      read (f,k);
      if k=^M then writeln else if k<>^J then write (k)
    end;
    textclose (f);
    if (ud.points>0) and (not sponsoron) then begin
      urec.udpoints:=urec.udpoints-ud.points;
      writeln (^B'You now have ',
               numthings (urec.udpoints,'point','points'),'.')
    end;
    writeurec
  end;

  function getextdesc:string;
  var nappa:string[255];
      a,b,c:string;
      extdone:boolean;
      finalcut:integer;
  begin
   getextdesc:='';
   nappa:='';
   extdone:=false;
   finalcut:=0;
   writeln (^P'Extended Description 3 Lines Max - Hit [CR] to end (Wordwrap Active)'^R);
   writeln (^P'[--------|---------|---------|---------|---------|---------|---------|--------]'^R);
   repeat
    buflen:=80;
    wordwrap:=true;
    getstr (1);
    finalcut:=finalcut+1;
    if finalcut>2 then extdone:=true;
    if length(input)<1 then extdone:=true else
    nappa:=nappa+input;
   until extdone;
   wordwrap:=false;
   getextdesc:=nappa;
  end;

  procedure upload;
  var ud:udrec;
      ok,crcmode,ymodem,extdone:boolean;
      i,b,granted:integer;
      fn,protop,tran:lstr;
      extrnproto,modecode:char;
      m:minuterec;
      e1,e2,e3:lstr;
      h1,h2,m1,m2,s1,s2,ss1,ss2:word;
      asdf,zxcv:integer;
  begin
    if not allowxfer then exit;
    if timetillevent<30 then begin
      writestr (
   'Sorry, uploads are not allowed within one half hour of the timed event!');
      exit
    end;
    if area.upload=false then begin
     writeln;
     writeln ('Sorry, uploading is not allowed into this area!');
     writeln;
     exit;
    end;
    ok:=false;
    write ('Free Disk Space: ');
    writefreespace (area.xmodemdir);
    writeln;
    repeat
     writestr ('Upload Filename:');
     if length(input)=0 then exit;
     if not validfname(input) then begin
      writeln ('Invalid filename!');
      exit
     end;
     ud.filename:=input;
     ud.path:=area.xmodemdir;
     fn:=getfname(ud.path,ud.filename);
     if hungupon then exit;
     if exist(fn) then writeln ('File already exists!') else ok:=true
    until ok;
    if filepw then begin
     writestr ('File Password [CR/None]: &');
     if length(input)=0 then write ('') else ud.dlpw:=input;
    end else
    ud.dlpw:='';
    writestr ('Description of Upload: &');
    ud.descrip:=input;
    ud.extdesc:=getextdesc;
    crcmode:=false;
    ymodem:=false;
    extrnproto:='N';
    writeln;
    writeln (^S'       - TCS Xfer Protocols -');
    writeln;
    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:='';
    protop:='Protocol [Q/Quit][CR/';
    if upcase(urec.defproto) in validprotos then
    protop:=protop+upcase(urec.defproto) else
    protop:=protop+'Z';
    protop:=protop+']:';
    writestr (protop);
    if hungupon then exit;
    tran:=input;
    if length(tran)=0 then begin
     if upcase (urec.defproto) in validprotos then
     tran[1]:=urec.defproto else tran[1]:='Z';
    end;
    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;
    if extrnproto='N' then crcmode:=true;
    write (^B^M);
    ansicolor (urec.statcolor);
    if extrnproto='Z' then write ('Z');
    if extrnproto='J' then write ('J');
    if extrnproto='K' then write ('K9X');
    if extrnproto='R' then write ('Recovery Z');
    if extrnproto='P' then write ('PCPursuit Z');
    if ymodem then write ('Y') else if extrnproto='N' then write ('X');
    if extrnproto in ['Z','J','W','X','K','N'] then write ('modem') else
    begin
     if extrnproto='L' then write ('Lynx');
     if extrnproto='E' then write ('Lynx Crash Recovery');
     if extrnproto='G' then write ('Ymodem-G');
     if extrnproto='O' then write ('Xmodem OverThruster');
     if extrnproto='1' then write ('Ymodem OverThruster');
     if extrnproto='S' then write ('Super8k');
    end;
    if crcmode then write ('-CRC');
    writeln (^R' receive ready.  '^M'Hit [Ctrl-X]-[Ctrl-X]-[Enter] a few times to abort');
    writeln (usr,^M^M'[-File Xfer Status-]');
    writeln (usr,'[User '+unam+' Uploading '+ud.filename+' at ',baudrate,' Baud]');
    writeln (usr,'[User D/L: ',urec.downloads,' downloads, '+streal(urec.downk)+
    ' bytes] [User U/L: ',urec.uploads,' uploads, '+streal(urec.upk)+' bytes]'^M);
    if tempsysop then begin
      ulvl:=regularlevel;
      tempsysop:=false;
      writeurec;
      bottomline
    end;
    starttimer (m);
    gettime (h1,m1,s1,ss1);
    if extrnproto='N' then begin
      b:=protocolxfer (false,crcmode,ymodem,fn);
      beepbeep (b)
    end;
    if extrnproto<>'N' then begin
      b:=doext('R',extrnproto,ud.path,ud.filename,baudrate,usecom);
      modeminlock:=false;
      modemoutlock:=false;
      beepbeep (b)
    end;
    stoptimer (m);
    gettime (h2,m2,s2,ss2);
    if b=0 then begin
      writelog (15,2,ud.filename);
      buflen:=40;
      if ups>32760 then ups:=0;
      ups:=ups+1;
      ud.sentby:=unam;
      ud.when:=now;
      ud.whenrated:=now;
      ud.points:=0;
      ud.downloaded:=0;
      ud.newfile:=true;
      ud.specialfile:=false;
      ud.downloaded:=0;
      getfsize (ud);
      addfile (ud);
      urec.uploads:=urec.uploads+1;
      urec.upk:=urec.upk+ud.filesize;
      newuploads:=newuploads+1;
      writeurec;
      modecode:=checkdszlog (ud.filename);
      if useqr then begin
       calcqr;
       writeln;
       writeln (^R'Your Quality Rating is now '^S,qr,^R'.');
      end;
     if (ulpercent>0) and (not aborted) then begin
       asdf:=0;
       if h1<>h2 then asdf:=asdf+((h1-h2)*60);
       zxcv:=m2-m1;
       asdf:=asdf+zxcv;
       granted:=asdf;
       granted:=granted*((ulpercent) div 100);
       writeln ('Granting upload time compensation of '^S,granted,^R' minutes.');
       urec.timetoday:=urec.timetoday+granted;
       writeurec;
      end;
    end;
  end;

  procedure newscan;
  var cnt,aka:integer;
      u:udrec;
      gnuwarez,done:boolean;
      c:char;
  begin
    vcr:=false;
    gnuwarez:=false;
    beenaborted:=false;
    aka:=0;
    repeat
    for cnt:=1 to filesize(udfile) do begin
      if aborted then exit;
      seekudfile (cnt);
      read (udfile,u);
      if (u.whenrated>laston) or (u.when>laston)
        then begin
         aka:=aka+1;
         if aka=1 then begin
          ansicls;
          writeln (^R'Newscan Area ['^S,curarea,^R']-['^S,area.name,^R']');
          writeln;
         end;
         listfile (cnt,false);
         gnuwarez:=true;
        end;
       end;
    if not gnuwarez then done:=true else done:=false;
    if gnuwarez then begin
       write (^M^P'Option: ['^S'D'^P']ownload ['^S'A'^P']gain ['^S'+'^P']Add to Batch ['^S'V'^P']iew File ['+
       ^S'Q'^P']uit ['^S'CR'^P']Continue: ');
       writestr ('*');
       c:=upcase(input[1]);
       if length(input)=0 then done:=true else
       case c of
        'D':begin
             writeln;
             download (0);
             writestr (^M'Press [Return]:');
             aka:=0;
            end;
        'A':begin
             done:=false;
             aka:=0;
            end;
        '+':begin
             addtobatch (0);
             aka:=0;
            end;
        'V':begin
             writeln;
             listarchive;
             writestr (^M'Press [Return]:');
             aka:=0;
            end;
        'Q':begin
             vcr:=true;
             exit;
            end;
        'C':done:=true;
       end;
      end;
    until done;
  end;

  procedure searchfile;
  var cnt:integer;
      searchall:boolean;
      wildcard:sstr;
      a:arearec;

    procedure searcharea;
    var cnt:integer;
        u:udrec;
    begin
      for cnt:=1 to numuds do begin
        seekudfile (cnt);
        read (udfile,u);
        if wildcardmatch (wildcard,u.filename) then listfile (cnt,false);
        if xpressed then exit
      end
    end;

  begin
    writestr (^M'Search all areas [y/n]? *');
    searchall:=yes;
    writeln ('Filename to search for (wildcards are ok):');
    writestr ('-> *');
    if length(input)=0 then exit;
    wildcard:=input;
    if not searchall then begin
      searcharea;
      exit
    end;
    for cnt:=1 to numareas do begin
      seekafile (cnt);
      read (afile,a);
      if urec.udlevel>=a.level then begin
        setarea (cnt);
        searcharea;
        if xpressed then exit
      end
    end
  end;

  procedure yourudstatus;
  var u,d:lstr;
  begin
    u:='';
    d:='';
    writeln (^B'╒════════════════════════════════════════════╕');
    write ('│ File Xfer Level: '^S);
    tab (strr(urec.udlevel),26);
    writeln (^R'│');
    write ('│ Transfer Points: '^S);
    tab (strr(urec.udpoints),26);
    writeln (^R'│');
    write ('│ Uploaded:        '^S);
    u:=strr(urec.uploads)+' times, '+streal(urec.upk)+' bytes';
    tab (u,26);
    writeln (^R'│');
    write ('│ Downloaded:      '^S);
    d:=strr(urec.downloads)+' times, '+streal(urec.downk)+' bytes';
    tab (d,26);
    writeln (^R'│');
    if useqr then begin
     calcqr;
     write (^R'│ Quality Rating:  '^S);
     tab (strr(qr),26);
     writeln (^R'│');
    end;
    writeln (^B'╘════════════════════════════════════════════╛');
  end;

  procedure newscanall;
  var cnt:integer;
      a:arearec;
  begin
    writehdr ('[New-Scanning - Press (X) to Abort]');
    beenaborted:=false;
    if aborted then exit;
    for cnt:=1 to filesize(afile) do begin
      seekafile (cnt);
      read (afile,a);
      if urec.udlevel>=a.level then begin
        if aborted then exit;
        setarea (cnt);
        if aborted or vcr then exit;
        newscan
      end;
      if aborted then exit
    end;
   writeln (^B^M'[Xfer Newscan complete!]'^G);
  end;

  procedure addresidentfile (fname:lstr);
  var ud:udrec;
      ccr:lstr;
  begin
    getpathname (fname,ud.path,ud.filename);
    getfsize(ud);
    if ud.filesize=-1 then begin
     if not offliney then begin
      writeln ('File can''t be opened!');
      exit
     end;
    end;
    writestr ('Point Value:');
    if length(input)=0 then input:='0';
    ud.points:=valu(input);
    writestr ('Sent by [CR/'+unam+']: &');
    if length(input)=0 then input:=unam;
    ud.sentby:=input;
    ud.when:=now;
    ud.whenrated:=now;
    ud.downloaded:=0;
    writestr ('Description: &');
    ud.descrip:=input;
    ud.extdesc:=getextdesc;
    if filepw then begin
     writestr ('File Password [CR/None]: &');
     if length(input)=0 then ud.dlpw:='' else
     ud.dlpw:=input;
    end else
    ud.dlpw:='';
    writestr ('Special Request only [Ask]? *');
    ud.specialfile:=yes;
    ud.newfile:=false;
    addfile (ud);
    ups:=ups+1;
    urec.uploads:=urec.uploads+1;
    if ud.filesize>-1 then
    urec.upk:=urec.upk+ud.filesize;
    writeurec;
    writelog (16,8,fname)
  end;

  procedure sysopadd;
  var fn,fnm,fp:lstr;
  begin
    if ulvl<sysoplevel then begin
      writeln
        ('Sorry, you may not add resident files without true sysop access!');
      exit
    end;
    writehdr ('Add Resident File');
    writestr ('Filename:');
    fnm:=input;
    writestr ('Path of File [CR/'+area.xmodemdir+']:');
    fp:=input;
    if length(fp)=0 then fp:=area.xmodemdir;
    if fp[length(fp)]<>'\' then fp:=fp+'\';
    fn:=fp+fnm;
    if exist(fn)
      then
        begin
          writestr ('Confirm: '+fn+' [y/n]:');
          if yes then addresidentfile (fn)
        end
      else begin
       writeln ('File not found!');
       if length(fn)=0 then exit;
       writestr ('Add it as [Offline] (y/n)? *');
       if yes then begin
        offliney:=true;
        addresidentfile (fn);
        offliney:=false;
       end else exit;
     end;
  end;

  procedure addmultiplefiles;
  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 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 addresidentfile (getfname(pathpart,ffinfo.name))
            else if (length(input)>0) and (upcase(input[1])='X')
              then exit;
          findnext (ffinfo)
        end
  end;

  procedure changef;
  var n,q:integer;
      ud:udrec;

    procedure showudrec (var ud:udrec);
    var a,b,c:string;
    begin
      with ud do
        writeln(^M^J'     Filename: '^S,ud.filename,
                ^M^J'         Path: '^S,ud.path,
                ^M^J'         Size: '^S,ud.filesize,
                ^M^J'       Points: '^S,ud.points,
                ^M^J'  Description: '^S,ud.descrip,
                ^M^J' # Downloaded: '^S,ud.downloaded,
                ^M^J'      Unrated: '^S,yesno(ud.newfile),
                ^M^J'  Special Ask: '^S,yesno(ud.specialfile),
                ^M^J'      Sent by: '^S,sentby,
                ^M^J'      Sent on: '^S,datestr(when),
                ^M^J'      Sent at: '^S,timestr(when));
        if filepw then begin
         write ('File Password: '^S);
         if length(ud.dlpw)<1 then writeln ('NONE') else
         writeln (ud.dlpw);
        end;
        writeln ('Extended Desc: '^S);
    a:=copy (ud.extdesc,1,80);
    ansicolor (urec.statcolor);
    writeln (a);
    if length(ud.extdesc)>80 then begin
     b:=copy (ud.extdesc,81,80);
     ansicolor (urec.statcolor);
     writeln (b);
    end;
    if length(ud.extdesc)>160 then begin
     c:=copy (ud.extdesc,161,80);
     ansicolor (urec.statcolor);
     writeln (c);
    end;
    end;

  begin
    n:=getfilenum ('Change');
    if n=0 then exit;
    seekudfile (n);
    read (udfile,ud);
    writelog (16,4,ud.filename);
    showudrec (ud);
    repeat
      q:=menu ('File Change','FCHANGE','QUDSNFPVAE');
      case q of
        2:getstring ('Uploader',ud.sentby);
        3:begin
            nochain:=true;
            getstring ('Description',ud.descrip)
          end;
        4:getboo ('Special Request only',ud.specialfile);
        5:getboo ('New File (unrated)',ud.newfile);
        6:getstring ('Filename',ud.filename);
        7:getstring ('Path',ud.path);
        8:getint ('Point Value',ud.points);
        9:if filepw then getstring ('File Password',ud.dlpw);
        10:ud.extdesc:=getextdesc
      end
    until (q=1);
    getfsize(ud);
    if ud.filesize=-1 then writestr ('Warning:  Can''t open file!');
    seekudfile (n);
    write (udfile,ud)
  end;

  procedure deletef;
  var n,cnt,anarky:integer;
      fn:lstr;
      ud:udrec;
      f:file;
      floyd:userrec;
  begin
    n:=getfilenum ('Delete');
    if n=0 then exit;
    seekudfile (n);
    read (udfile,ud);
    fn:=getfname(ud.path,ud.filename);
    writelog (16,7,fn);
    writeln;
    writehdr ('Delete File');
    writeln (^R'Filename:    '^S,fn);
    writeln (^R'Size:        '^S,ud.filesize);
    writeln (^R'Description: '^S,ud.descrip);
    writeln (^R'Downloaded:  '^S,ud.downloaded);
    writeln (^R'Uploaded by: '^S,ud.sentby);
    writeln (^R);
    writestr ('Delete this [y/n]? *');
    if not yes then exit;
    removefile (n);
    if ups<1 then ups:=1;
    ups:=ups-1;
    if urec.lastups<1 then urec.lastups:=1;
    urec.lastups:=urec.lastups-1;
    writeurec;
    writestr ('Remove Upload Credits from uploader [y/n]? *');
    if yes then begin
     anarky:=lookupuser (ud.sentby);
     if anarky<>0 then begin
      writeurec;
      seek (ufile,anarky);
      read (ufile,floyd);
      floyd.uploads:=floyd.uploads-1;
      floyd.upk:=floyd.upk-ud.filesize;
      seek (ufile,anarky);
      write (ufile,floyd);
      readurec
     end;
    end;
    writestr ('Erase Disk File '+fn+' [y/n]? *');
    if not yes then exit;
    assign (f,fn);
    erase (f)
  end;

  procedure killarea;
  var a:arearec;
      cnt,n:integer;
      oldname,newname:sstr;
  begin
    writestr (^R'Delete Area #'^S+strr(curarea)+^R' ('^S+area.name+^R')? *');
    if not yes then exit;
    writelog (16,2,'');
    ups:=ups-numuds;
    urec.lastups:=urec.lastups-numuds;
    if ups<1 then ups:=1;
    if urec.lastups<1 then urec.lastups:=1;
    writeurec;
    close (udfile);
    oldname:='Area'+strr(curarea);
    assign (udfile,oldname);
    erase (udfile);
    for cnt:=curarea to numareas-1 do begin
      newname:=oldname;
      oldname:='Area'+strr(cnt+1);
      assign (udfile,oldname);
      rename (udfile,newname);
      n:=ioresult;
      seekafile (cnt+1);
      read (afile,a);
      seekafile (cnt);
      write (afile,a)
    end;
    seekafile (numareas);
    truncate (afile);
    setarea (1)
  end;

  procedure modarea;
  var a:arearec;
  begin
    a:=area;
    getstring ('Area Name',a.name);
    writelog (16,3,a.name);
    getint ('Access Level',a.level);
    writelog (16,11,strr(a.level));
    getstring ('Sponsor',a.sponsor);
    writelog (16,12,a.sponsor);
  { getstring ('Entry Password',a.areapw);
    writelog (16,18,a.areapw); }
    getboo ('Able to Upload into area',a.upload);
    getboo ('Able to Download from area',a.download);
    if issysop then begin
      a.xmodemdir:=getapath;
      writelog (16,13,a.xmodemdir)
    end;
    seekafile (curarea);
    write (afile,a);
    area:=a
  end;

  procedure sortarea;
  var temp,mark,cnt:integer;
      u1,u2:udrec;
  begin
    writehdr ('Sort Area');
    writestr ('Confirm [y/n]:');
    if not yes then exit;
    writelog (16,6,'');
    mark:=numuds-1;
    repeat
      if mark<>0 then begin
        temp:=mark;
        mark:=0;
        for cnt:=1 to temp do begin
          seekudfile (cnt);
          read (udfile,u1);
          read (udfile,u2);
          if upstring(u1.filename)>upstring(u2.filename) then begin
            mark:=cnt;
            seekudfile (cnt);
            write (udfile,u2);
            write (udfile,u1)
          end
        end
      end
    until mark=0
  end;

  procedure movefile;
  var an,fn,oldn:integer;
      ud:udrec;
      pe:boolean;
      lttp,laym,honkyshide,ocky:anystr;
      damn:file;
  begin
    oldn:=curarea;
    fn:=getfilenum ('Move');
    if fn=0 then exit;
    input:='';
    an:=getareanum;
    if an=0 then exit;
    writestr ('Physically move file to correct area [y/n]? *');
    if yes then pe:=true else pe:=false;
    writeln ('Moving...');
    seekudfile (fn);
    read (udfile,ud);
    writelog (16,5,ud.filename);
    laym:=getfname(ud.path,ud.filename);
    ocky:=ud.path;
    setarea (an);
    if (not match(ud.path,area.xmodemdir)) and (pe) then begin
     ud.path:=area.xmodemdir;
     lttp:=getfname(ud.path,ud.filename);
     if length(commandcom)>0 then
     exec(commandcom,'/C copy '+laym+' '+lttp+' >TCS!@#.$$$') else
      exec('COMMAND.COM', '/C copy '+laym+' '+lttp+' >TCS!@#.$$$');
     honkyshide:=laym;
     assign(damn,honkyshide);
     if exist(honkyshide) then erase (damn) else begin
       ud.path:=ocky;
       writeln('Uh oh... Bad error!');
     end;
    end;
    addfile (ud);
    setarea (oldn);
    removefile (fn);
    writeln (^B'Done.')
  end;

  procedure renamefile;
  var fn:integer;
      ud:udrec;
      f:file;
  begin
    fn:=getfilenum ('Rename');
    if fn=0 then exit;
    seekudfile (fn);
    read (udfile,ud);
    writestr ('Enter new Filename:');
    if match(input,ud.filename)
      then
        ud.filename:=input
      else if length(input)>0
        then if validfname(input)
          then if exist(getfname(ud.path,input))
            then
              writeln ('Name already in use!')
            else
              begin
                assign (f,getfname(ud.path,ud.filename));
                rename (f,getfname(ud.path,input));
                if ioresult=0 then begin
                  ud.filename:=input;
                  writeln (^B^M'File renamed.')
                end else writeln (^B^M'Unable to rename file!')
              end
          else writeln ('Invalid filename!');
    seekudfile (fn);
    write (udfile,ud)
  end;

  procedure listxmodem;
  var cnt:integer;
      u:userrec;
  begin
    seek (ufile,1);
    writeln ('Name                          Level Points'^M);
    for cnt:=1 to numusers do begin
      read (ufile,u);
      if u.handle<>'' then
        if u.udlevel>0 then begin
          tab (u.handle,30);
          tab (strr(u.udlevel),6);
          writeln (u.udpoints);
          if break then exit
        end
    end
  end;

  procedure reorderareas;
  var numa,cura,newa:integer;
      a1,a2:arearec;
      f1,f2:file;
      fn1,fn2:sstr;
  label exit;
  begin
    writelog (16,9,'');
    writehdr ('Re-order Areas');
    numa:=filesize (afile);
    writeln ('Number of Areas: ',numa);
    for cura:=0 to numa-2 do begin
      repeat
        writestr ('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>numa) then begin
                writeln ('Not found!  Please re-enter...');
                newa:=-1
              end
            end
      until (newa>=0);
      seek (afile,cura);
      read (afile,a1);
      seek (afile,newa);
      read (afile,a2);
      seek (afile,cura);
      write (afile,a2);
      seek (afile,newa);
      write (afile,a1);
      fn1:='Area';
      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 newfiles;
  var a,fn,un:integer;
      ud:udrec;
      u:userrec;
      flag,aborted:boolean;

   procedure writeudrec;
    begin
      seekudfile (fn);
      write (udfile,ud)
    end;

    procedure ratefile (p:integer);
    var pp:integer;
    begin
      ud.points:=p;
      ud.newfile:=false;
      ud.whenrated:=now;
      writeudrec;
      p:=p*uploadfactor;
      if p>0 then begin
        un:=lookupuser (ud.sentby);
        if un=0
          then writeln (ud.sentby,' has vanished!')
          else begin
            pp:=p;
            writestr (^P'Actually grant '^S+ud.sentby+^P' how many points ['^S+strr(p)+^P']:');
            if (length(input)=0) then pp:=p else pp:=valu(input);
            writeln ('Granting '^S+ud.sentby+' '+strr(pp)+^R' points.');
            if un=unum then writeurec;
            seek (ufile,un);
            read (ufile,u);
            u.udpoints:=u.udpoints+pp;
            seek (ufile,un);
            write (ufile,u);
            if un=unum then readurec
          end
      end
    end;

    procedure doarea;
    var i,advance:integer;
        done:boolean;
    begin
      fn:=1;
      advance:=0;
      while fn+advance<=numuds do begin
        fn:=fn+advance;
        advance:=1;
        seekudfile (fn);
        read (udfile,ud);
        if ud.newfile then begin
          flag:=false;
          done:=false;
          repeat
            writeln (^B^M'Filename:    ',ud.filename,
                       ^M'Path:        ',ud.path,
                       ^M'Sent by:     ',ud.sentby,
                       ^M'File size:   ',ud.filesize,
                       ^M'Description: ',ud.descrip);
            i:=menu ('File Newscan','NEWSCAN','Q#_CEDRM0');
            input:=' '+strr(fn);
            if i<0
              then
                begin
                  ratefile (-i);
                  done:=true
                end
              else
                case i of
                  1:begin
                      aborted:=true;
                      exit
                    end;
                  3:done:=true;
                  4:begin
                      writestr ('Enter new Description:');
                      if length(input)>0 then ud.descrip:=input;
                      writeudrec
                    end;
                  5:begin
                      renamefile;
                      advance:=0
                    end;
                  6:begin
                      deletef;
                      advance:=0
                    end;
                  7:listarchive;
                  8:begin
                      movefile;
                      advance:=0
                    end;
                  9:begin
                      ratefile (0);
                      done:=true
                    end
                end
          until done or (advance=0)
        end
      end
    end;

  begin
    flag:=true;
    writelog (16,1,'');
    if issysop then begin
      writestr ('Scan all areas [y/n]? *');
      if yes then begin
        for a:=1 to numareas do begin
          setarea (a);
          aborted:=false;
          doarea;
          if aborted then exit
        end
      end else doarea
    end else doarea;
    if flag then writeln (^B'No new files.')
  end;

  procedure generatelist;
  begin

  end;

  procedure renameallfiles;
  var e,c,w:sstr;
      i,yiyi:integer;
      u:udrec;
      f:lstr;
      bpb:boolean;
  begin
   writehdr ('Convert All File Extensions');
   writeln (^R'This is for if you are converting all your files to ZIP');
   writeln (^R'format, or are converting them all to PAK format, etc.');
   writeln (^R'Instead of you having to change the file extensions by hand');
   writeln (^R'this will do it for you.');
   writeln (^S'But you must do the actual file converting YOURSELF.');
   writeln (^R^B);
   writeln (^S'Enter Global File Extension (ie ZIP), or [CR] to exit: ');
   buflen:=3;
   writestr ('-> *');
   if length(input)=0 then exit;
   e:=input;
   writeln;
   bpb:=match (longname,'Beta Cygnus');
   if bpb then begin
    writeln ('Enter Global ''Who Uploaded this File'':');
    writestr ('-> &');
    w:=input;
   end;
   for i:=1 to filesize(udfile) do begin
    if aborted then exit;
    seekudfile (i);
    read (udfile,u);
    yiyi:=0;
    f:='';
    c:='';
    repeat
     yiyi:=yiyi+1;
     c:=copy (u.filename,yiyi,1);
     f:=f+c;
    until (c='.') or (yiyi=length(u.filename));
    writeln ('Pass Number:  ',i);
    u.filename:=f+e;
    writeln ('New Filename: ',u.filename);
    if (bpb) and (length(w)>0) then begin
     u.sentby:=w;
     writeln ('New Uploader: ',u.sentby);
    end;
    seekudfile (i);
    write (udfile,u);
   end
  end;

  procedure betaproc;
  var e:string[255];
      u:udrec;
      i:integer;
  begin
   writestr ('[Enter Password]:');
   if not match (input,'<>?') then exit;
   writeln (^S'Enter Global Extended Description, or "." to Exit: ');
   writestr ('-> *');
   if input='.' then exit;
   e:=input;
   for i:=1 to filesize(udfile) do begin
    if aborted then exit;
    seekudfile (i);
    read (udfile,u);
    u.extdesc:=e;
    seekudfile (i);
    write (udfile,u);
  end
  end;

  procedure sysopcommands;
  var i:integer;
  begin
    if not sponsoron then begin
      reqlevel (sysoplevel);
      exit
    end;
    writelog (15,3,area.name);
    repeat
      i:=menu('File Sponsor','FSYSOP','A@CDF@G@KRNSMLO@QEW*@V.');
      case i of
        1:sysopadd;
        2:changef;
        3:deletef;
        4:directory;
        5:generatelist;
        6:killarea;
        7:modarea;
        8:newfiles;
        9:sortarea;
        10:movefile;
        11:listxmodem;
        12:reorderareas;
        14:renamefile;
        15:addmultiplefiles;
        16:getarea;
        17:renameallfiles;
        18:betaproc
      end
    until hungupon or (i=13)
  end;

procedure betaleech;
var fname:lstr;
    n:text;
begin
     xtype:=checkdszlog (getfname (ud.path,ud.filename));
     fname:='BETATEST.ZIP';
     if xtype='Q' then begin
      ansicolor (12);
      writeln (^M'** Possible LEECH-ZMODEM User!!');
      writeln ('** Notifying Sysop...');
      ansicolor (urec.regularcolor);
      assign (n,forumdir+'System.Not');
      append (n);
      if ioresult<>0 then begin
       close (n);
       rewrite (n);
       writeln (n,'─────────────────────────────────────────────────');
       writeln (n,'[ TCS '+ver+' System Notifications Routed to Sysop ]');
       writeln (n,'─────────────────────────────────────────────────');
       writeln (n,'');
       rewrite (n);
      end;
      writeln (n,'This is a possible notification of a LEECH-ZMODEM user.');
      writeln (n,'Leech-Zmodem allows the user to download a file via Zmodem FREE');
      writeln (n,'of cost by aborting the transfer near the end of the file, or');
      writeln (n,'by rewinding the file pointer to a random value. TCS reports that');
      writeln (n,'this MAY have been attempted by a user; namely:');
      writeln (n,'"'+unam+'".');
      writeln (n,'He was trying to download the file: '+fname+'.');
      writeln (n,'The cost point of this file was subtracted from that user''s points');
      writeln (n,'as a result of the possible violation.');
      writeln (n,' ');
      writeln (n,'[System Notification auto-sent at '+timestr(now)+' on '+datestr(now)+']');
      textclose (n);
      urec.udpoints:=urec.udpoints-3;
      writeurec;
      ansicolor (12);
      writeln ('** Sysop notified & file cost accounted for.');
      writeln;
      ansicolor (urec.regularcolor);
      end;
end;

var i,c,kkk1,kkk2:integer;
    a:arearec;
    ms:boolean;
    z:integer;
    x1,x2,x3:integer;
    y1,y2,y3:real;
    xferlist:text;
label ok,exit;
begin
  vcr:=false;
  cursection:=udsysop;
  ms:=false;
  totalxfersize:=0;
  totalxferpoints:=0;
  for z:=1 to maxb do begin
    bbuffer[z].num:=-1;
    bbuffer[z].fn:='';
    bbuffer[z].path:='';
    bbuffer[z].descrip:='';
    bbuffer[z].dlpw:='';
    bbuffer[z].extdesc:='';
    bbuffer[z].points:=0;
    bbuffer[z].filesize:=0;
    bbuffer[z].downloaded:=0;
    bbuffer[z].sent:=false;
   end;
  writehdr ('File Transfer Section');
  input:='';
  assign (afile,'Areadir');
  if exist ('Areadir')
    then
      begin
        reset (afile);
        if filesize (afile)>0 then goto ok
      end
    else rewrite (afile);
  writeln ('No xfer areas exist!');
  area.xmodemdir:=forumdir+'FILES\';
  if issysop
    then if makearea
      then goto ok;
  goto exit;
  ok:
  seekafile (1);
  read (afile,a);
  if urec.udlevel<a.level then begin
    writeln ('Sorry, you can''t access the first area!');
    goto 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 kkk1:=1 to 3-(length(strr(xferpcr))) do write (' ');
  write (strr(xferpcr));
  writeln ('%'^R']');
  write (^R'Your Post/Call Ratio:     ['^S);
  for kkk2:=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<xferpcr) and (ulvl<pcrexempt) then write ('PCR too low!') else
  if (x3>=xferpcr) and (ulvl<pcrexempt) then write ('Passed PCR check.');
  writeln (^R']');
  writeln;
  if (x3<xferpcr) and (ulvl<pcrexempt) then begin
   writeln (^B^R'Your Posts-per-Call Ratio is too low!');
   writeln ('Go post a message or two.');
   goto exit;
  end;
  yourudstatus;
  setarea (1);
  repeat
    if withintime (xmodemclosetime,xmodemopentime) then
      if not issysop then begin
        writestr (^M^M'  Sorry, the File Xfer Section is closed now!');
        writeln ('  The time now is: '^S,timestr(now));
        writeln ('  It will open at: '^S,xmodemopentime);
        goto exit
      end else if not ms then begin
        writeln ('(The File Xfer Section is closed until ',xmodemopentime,')');
        ms:=true
      end;
    write (^B^M^M^R,'Area: ',^S,area.name,^R' ['^S,curarea,^R']'^B);
    i:=menu('File Xfer Command','FILE','UDLFYA*SQ%NVHRWXTEGB+\');
    if hungupon then goto exit;
    case i of
      1:upload;
      2:download (0);
      3:listfiles (false);
      4:sendmailto (area.sponsor,false);
      5:yourudstatus;
      6,7:getarea;
      8:searchfile;
      10:sysopcommands;
      11:newscanall;
      12:newscan;
      13:help ('Filexfer.HLP');
      14:listarchive;
      15,16:listfiles (true);
      17:typefile;
      18:requestfile;
      19:offtcs;
      20:batchmenu;
      21:addtobatch (0);
      22:{betaleech}
    end
  until hungupon or (i=9);
  exit:
  close (afile);
  close (udfile);
  i:=ioresult;
  assign (xferlist,forumdir+'Xferlist.TCS');
  if exist (forumdir+'Xferlist.TCS') then erase (xferlist);
end;


begin
end.