Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/FAQ-S.ZIP/FILEXFER.PAS

Pascal/Delphi Source File | 1991-05-04 | 66.3 KB | 2,379 lines

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

unit filexfer;

interface

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

procedure udsection;
var cn:byte;
implementation

procedure filemenu;
begin
filemenu;
end;

procedure udsection;
{$I file2}

  procedure listfile (n:integer; extended:boolean); forward;
  procedure listfiles (extended:boolean); forward;
  function capfir(inString:STRING):STRING; forward;

  function findprot(rors,prot:char):boolean;
  var bonzo:file of protorec; sod:boolean;

  begin
       sod:=false;
       assign(bonzo,bbsdatadir+'PROT'+upcase(rors)+'.CFG');
       reset(bonzo);
       while not(eof(bonzo)) and not(sod) do
             begin
                  read(bonzo,protrec);
                  if protrec.letter=upcase(prot) then sod:=true;
             end;
       findprot:=sod;
       prprog:=protrec.progname;
       prcomm:=protrec.commfmt;
       prdesc:=protrec.desc;
       close(bonzo);
  end;

procedure xtendedlist;
var num:integer;
    ud:udrec;
begin
  writestr ('[Enter File Number to List Extended Descrip]: *');
  num:=valu(input);
  if num>numuds then exit;
  if num<1 then exit;
  seekudfile (num);
  read (udfile,ud);
  writeln (^U'═════════════════════════════════════════════════════════════════════════════');
  writeln (^S,ud.extdesc);
  writeln (^U'═════════════════════════════════════════════════════════════════════════════');
end;

procedure whoup;

procedure toplinewho;
 begin
  if asciigraphics in urec.config then begin
  writeln('┌───┬───────────────┬──────────────────────────────┬────────┬────────────┐');
  writeln('│ '^S'#'^R' │   '^S'Filename'^R'    │        '^S'Uploaded by'^R'           │ '^S'Cost  '^R' │ '+
  ^S'Downloaded'^R' │');
  writeln('├───┼───────────────┼──────────────────────────────┼────────┼────────────┤') end else begin
  writeln('+---+---------------+------------------------------+--------+------------+');
  writeln('| '^S'#'^R' |   '^S'Filename'^R'    |        '^S'Uploaded by'^R'           | '^S'Cost  '^R' | '+
          ^S'Downloaded'^R' |');
  writeln('|---|---------------|------------------------------|--------|------------|');
   end;
  end;

procedure botlinewho;
 begin
  if asciigraphics in urec.config then
  writeln(^R'└───┴───────────────┴──────────────────────────────┴────────┴────────────┘') else
  writeln(^R'+---+---------------+------------------------------+--------+------------+');
 end;
  var ud :udrec;
      cnt:integer;
  begin
  toplinewho;
  for cnt:=1 to numuds do
   begin
     seekudfile (cnt);
     read (udfile,ud);
     if asciigraphics in urec.config then begin
     write (^R'│ '^S,strr(cnt));
     spacelen(2-length(strr(cnt)));
     write (^R'│ '^S,ud.filename);
     spacelen(14-length(ud.filename));
     write (^R'│ '^S,ud.sentby);
     spacelen(29-length(ud.sentby));
     write (^R'│ '^S,ud.points);
    spacelen(7-length(strr(ud.points)));
     write (^R'│ '^S,ud.downloaded);
     spacelen(11-length(strr(ud.downloaded)));
     writeln (^R'│');
    end else begin
     write (^R'| '^S,strr(cnt));
     spacelen(2-length(strr(cnt)));
     write (^R'| '^S,ud.filename);
     spacelen(14-length(ud.filename));
     write (^R'| '^S,ud.sentby);
     spacelen(29-length(ud.sentby));
     write (^R'| '^S,ud.points);
    spacelen(7-length(strr(ud.points)));
     write (^R'| '^S,ud.downloaded);
     spacelen(11-length(strr(ud.downloaded)));
     writeln (^R'|');
    end;
   end;
  botlinewho;
  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;

  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 newscan 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 getstringgg (t:lstr; var m);
  var q:lstr absolute m;
      mm:lstr;
  begin
    writeln ('Old ',t,': ',q);
    writestr ('Enter new '+t+' [CR/no change, "!" for null]:');
    mm:=input;
    if length(mm)<>0 then q:=mm;
    if mm='!' then q:='';
    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 (^S+ffinfo.name,13);
    if (a and 16)=16
      then write (^S'Directory')
      else write (^S,ffinfo.size);
    if (a and 1)=1 then write (^P' [',^S,'read-only',^P,']'^R);
    if (a and 2)=2 then write (^P' [',^S,'hidden',^P,']'^R);
    if (a and 4)=4 then write (^P' [',^S,'system',^P,']'^R);
    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 (int:integer);
  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;
    if int<1 then begin
     n:=getfilenum('List');
     if n=0 then exit;
    end else n:=int;
    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;
    write (^R'Archive Type: '^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='LZH' then writeln ('LHARC') else
    if (sussuh<>'ARC') and (sussuh<>'PAK') and (sussuh<>'ZIP') and
       (sussuh<>'LZH') then begin
     writeln ('Unknown!');
     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'[4]: LHARC');
      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' else
      if ock='4' then sussuh:='LZH';
     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) else
    if sussuh='LZH' then lharcview (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;
  input:=upstring(input);
  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;

  procedure download (autoselect:integer; checktheok:boolean);
  var totaltime:sstr;
      num,fsize,actualsize,mins,secs,i,b,dsziactualsize,realtime:integer;
      ud:udrec;
      fname,faqrulez,protop,byteblok:lstr;
      ymodem,okselect:boolean;
      f:file;
      m:sstr;
      extrnproto:char; resp:char; byewhendone:boolean;
      n:text;
      ok:boolean;
  begin
    if not allowxfer then exit;
    if nofiles then exit;
    if percent (urec.uploads,urec.downloads)<udratio then begin
      writeln ('Your Upload/Download ratio is too low!   Upload some files!');
      exit;
    end;
    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 checktheok then begin
    if (area.download=false) then begin
     writeln;
     writeln ('Sorry, downloading is not allowed from this area!');
     writeln;
     exit;
    end;
    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:=' ';
    listprotocols(0);
    if hungupon then exit;
    writestr(^R+'Protocol '^P'['^R'CR'^P'/'+^S+urec.defproto+^S'  Q'^R'uit'^P']'^R' &');
    if hungupon then exit;
    if length(input)=0 then extrnproto:=urec.defproto else extrnproto:=upcase(input[1]);
    if upstring (input)='Q' then exit;
    okselect:=findprot('S',extrnproto);
    if not okselect then exit;

    fname:=getfname(ud.path,ud.filename);

    assign (f,fname);
    reset (f);
    iocode:=ioresult;
    if iocode<>0 then
      begin
      writeln; writeln('ERROR: Unable to locate file ',fname);
        fileerror ('DOWNLOAD',fname);
        exit
      end;

    fsize:=filesize(f);
    actualsize:=fsize;
    close (f);
    totaltime:=minstr(fsize);
    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;
    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;
writeln;

        askaboutbye;
    if answer='A' then exit;
    wipedszlog;

    if (ansigraphics in urec.config) then write (#27+'[2J') else write (^L);
    if asciigraphics in urec.config then begin
    writeln (^B);
    writeln (^R'┌─────────────────────────────────────────┐');
    write (^R'│ '^S'Filename:       '^S);
    tab (ud.filename,24);
    writeln (^R'│');
    write (^R'│ '^S'Uploaded by:    '^S);
    tab (ud.sentby,24);
    writeln (^R'│');
    write (^R'│ '^S'Downloaded:     '^S);
    faqrulez:='';
    faqrulez:=strr(ud.downloaded)+' time';
    if (ud.downloaded<>1) then faqrulez:=faqrulez+'s';
    tab (faqrulez,24);
    writeln (^R'│');
    if ymodem then fsize:=(fsize+7) div 8;
    if fsize=0 then fsize:=1;
    write (^R'│ '^S'Bytes to send:  '^S);
    byteblok:=^S+strlong(ud.filesize)+^R+' bytes';
    tab (byteblok,26);
    writeln (^R'│');
    write (^R'│ '^S'Transfer Time:  '^S);
    tab (totaltime,24);
    writeln (^R'│');
    writeln (^R'├─────────────────────────────────────────┤');
    writeln (^R'│    Hit ['^S'Ctrl X'^R'] a few times to Abort    │');
    writeln (^R'└─────────────────────────────────────────┘');
    writeln;
    end else begin
    writeln (^B);
    writeln (^R'+-----------------------------------------+');
    write (^R'| '^S'Filename:       '^S);
    tab (ud.filename,24);
    writeln (^R'|');
    write (^R'| '^S'Uploaded by:    '^S);
    tab (ud.sentby,24);
    writeln (^R'|');
    write (^R'| '^S'Downloaded:     '^S);
    faqrulez:='';
    faqrulez:=strr(ud.downloaded)+' time';
    if (ud.downloaded<>1) then faqrulez:=faqrulez+'s';
    tab (faqrulez,24);
    writeln (^R'|');
    if ymodem then fsize:=(fsize+7) div 8;
    if fsize=0 then fsize:=1;
    write (^R'| '^S'Bytes to send:  '^S);
    byteblok:=^S+strlong(ud.filesize)+^R+' bytes';
    tab (byteblok,26);
    writeln (^R'|');
    write (^R'| '^S'Transfer Time:  '^S);
    tab (totaltime,24);
    writeln (^R'|');
    writeln (^R'|-----------------------------------------|');
    writeln (^R'|    Hit ['^S'Ctrl X'^R'] a few times to Abort    |');
    writeln (^R'+-----------------------------------------+');
    writeln;
    end;
      b:=doext ('S',extrnproto,ud.path,ud.filename,baudrate,usecom);
      if b<>0 then b:=2;
      modeminlock:=false;
      beepbeep (b);

      xtype:=checkdszlog (ud.filename);
      if (upcase(xtype)='Q') then
       begin
       possiblelzm (ud.points);
       b:=2;
       end;
      if (b=0) or (b=1) then begin
      writelog (15,1,fname);
      writeln;
      clrscr;
      ud.downloaded:=ud.downloaded+1;
      urec.downloads:=urec.downloads+1;
      urec.udpoints:=urec.udpoints-ud.points;
      urec.downk:=urec.downk+ud.filesize;
      seekudfile (num);
      write (udfile,ud);
      showhisstats;
      writeurec;
   if answer='H' then laterdays
    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;

  procedure processfile(fn,todir:lstr);
  var fn1:lstr; util:integer;
  begin
    write(^P' - Processing. ');
    util:=pos('.',fn);
    if util=0 then fn1:=fn else fn1:=copy(fn,1,util-1);
        if exist ('PROCESS.BAT') then
exec(getenv('COMSPEC'),' /C PROCESS.BAT '+fn+' '+todir+' '+fn1);
  end;


  procedure upload;
  var ud:udrec;
      ok,crcmode,ymodem,extdone,cool:boolean;
      i,b,granted,ultime:integer;
      dah:real;
      fn,protop:lstr;
      extrnproto:char;
      e1,e2,e3:lstr;
      f:file;
      time:string;
  var process:boolean; dir1:lstr;

  procedure acceptfile(fname:lstr);
  var process:boolean; dir1,extend:lstr; f1,f2:text; fn1,fn2:mstr; fn3:lstr;
  begin
    process:=true;
    dir1:=copy(area.xmodemdir,1,length(area.xmodemdir)-1);
    extend:=copy(fname,length(fname)-3,4);
    extend:=upstring(extend);
    write(^R'Received File: '^S+fname);
    fn1:=faqdir+'PROCNAME.'+strr(conn);
        fn2:=faqdir+'PROCMSG.'+strr(conn);
    assign(f1,fn1); assign(f2,fn2);
    if exist(fn1) then erase(f1);
    if exist(fn2) then erase(f2);
    if process then processfile(fname,extend);
    if exist(fn1) then begin
                reset(f1);
                readln(f1,fn3);
                close(f1);
                ud.filename:=fn3;
                fname:=fn3;
               end;
    if exist(fn2) then begin
                reset(f2);
                readln(f2,fn3);
                close(f2);
                write(^S'  '+fn3+'. ');
               end;
    if not exist(xferdir+fname) then exit;

    writeln(^P'Posting.');
exec(getenv('COMSPEC'),' /C copy '+xferdir+fname+' '+dir1+' >nul');
exec(getenv('COMSPEC'),' /C del '+xferdir+fname+' >nul');
   end;

   procedure getextras;
   var r:registers; ffinfo:searchrec;
       tpath:anystr; b:byte; cnt:integer; mm:text; fname:lstr;

   begin
    writeln; writeln(^R'Checking Upload Discrepancy.');
    writeln;
    tpath:=xferdir+'*.*'; cnt:=0;
    findfirst (tpath,$17,ffinfo);

if doserror<>0 then begin
            writeln('File not received. [Upload Aborted]');
            exit;
            end;

          if ffinfo.name[1]<>'.' then begin
                    fname:=ffinfo.name;
          if answer<>'H' then begin
            writeln;
                writestr(^R'Describe file '^S+ffinfo.name+^R+': *');
            ud.programname:=input;
            writestr(^R'Disk Number: *');
            ud.disknum:=valu(input);
                        if ud.disknum<1 then ud.disknum:=1;
            writestr(^R'Total # of disks: *');
            ud.totaldisk:=valu(input);
                        if ud.totaldisk<1 then ud.totaldisk:=1;
            writestr(^R'Download P/W for file: *');
            ud.dlpw:=input;
            end else begin
            ud.programname:='Upload with no description.';
                        ud.disknum:=1;
                        ud.totaldisk:=1;
            ud.dlpw:='';
                        ud.private:='';
            end;
          acceptfile(fname);
      end;
end;

  var pointv:longint;
          pp: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:=upstring(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
     buflen:=30;
     writestr ('File Password [CR/None]: &');
     if length(input)=0 then ud.dlpw:='' else ud.dlpw:=input;
    end else
    ud.dlpw:='';
    writestr ('Private for: &');
    if length(input)=0 then ud.private:='' else ud.private:=input;
    buflen:=27;
    writestr ('Program Description: &');
    ud.programname:=input;
    buflen:=2;
    writestr ('Disk Number: &');
    ud.disknum:=valu(input);
    if ud.disknum<1 then ud.disknum:=1;
    buflen:=2;
    writestr ('Total Disks: &');
    ud.totaldisk:=valu(input);
    if ud.totaldisk<1 then ud.totaldisk:=1;
    buflen:=45;
    ud.extdesc:=getextdesc;
    buflen:=40;
    if ups>32765 then ups:=0;
    inc(ups);
    ud.sentby:=unam;
    ud.when:=now;
    ud.whenrated:=now;
    ud.points:=0;
    ud.downloaded:=0;
        ud.newfile:=true;
    ud.specialfile:=false;
    crcmode:=false;
    ymodem:=false;
    extrnproto:='N';
    listprotocols (1);
    if hungupon then exit;
    writestr(^R+'Protocol '^P'['^R'CR'^P'/'+^S+urec.defproto+^S'  Q'^R'uit'^P']'^R' &');
    if hungupon then exit;
    if length(input)=0 then extrnproto:=urec.defproto else extrnproto:=upcase(input[1]);
    if upstring (input)='Q' then exit;
    cool:=findprot('R',extrnproto);
    if not cool then exit;

    askaboutbye;
    if answer='A' then exit;

    ultime:=timer;
    if tempsysop then begin
      ulvl:=regularlevel;
      tempsysop:=false;
      writeurec;
      bottomline
    end;
      begin
      wipedszlog;
      b:=doext ('R',extrnproto,xferdir,ud.filename,baudrate,usecom);
      modeminlock:=false;
      modemoutlock:=false;
      beepbeep (b)
    end;
      xtype:=checkdszlog (ud.filename);
    if b>=1 then begin
      writeln;
      clrscr;
      fn:=getfname (xferdir,ud.filename);
      if exist (fn) then begin
       assign(f,fn);
       erase (f);
      end;
     exit;
    end;
    if b=0 then begin
        writeln;
        clrscr;
        acceptfile(ud.filename);
    getfsize(ud);
       {pointv:=pointvalue;
        pointv:=pointv*1000;}
        if (autovalidate) and (pointvalue>0) then begin
        ud.points:=(ud.filesize div pointvalue div 1024);
        writeln (^R'Granting '+ud.filename+' '+strr(ud.points)+^R' points.');
        end else ud.points:=0;
        pp:=ud.points*uploadfactor;
        writeln (^R'Granting '^S+ud.sentby+' '+strr(pp)+^R' points.');
        ud.newfile:=false;
        urec.udpoints:=urec.udpoints+pp;
        addfile(ud);
    inc(urec.uploads);
    urec.upk:=urec.upk+ud.filesize;
    newuploads:=newuploads+1;
    writeurec;
    end;
     if (ulpercent>0) and (not aborted) then begin
    { endtime:=timer;
      if endtime<starttime then endtime:=endtime+1440;
      xfertimecredit:=(endtime-starttime);
      writeln;
      granted:=xfertimecredit;
      granted:=granted*(ulpercent div 100);
      settimeleft (timeleft+granted);
      str (timeleft,time); }
      ultime:=timer-ultime;
      if ultime<0 then ultime:=ultime+1440;
      granted:=ultime*(ulpercent div 100);
      writeln (^R'Granting upload time compensation of '^S+strr(granted)+^R' minutes.');
      urec.timetoday:=urec.timetoday+granted;
      writeurec;
     end;
    avrcps;
    if zipcomment then begin
    addcomment (area.xmodemdir,ud.filename);
    end;
    showhisstats;
    if answer='H' then laterdays;
  end;

  procedure searchfile;
  var cnt,cntt,totalcnt:integer;
      searchall:boolean;
      wildcard:sstr;
      a:arearec;
      stext:anystr;

    procedure searcharea;
    var cnt,knt:integer; needbox:boolean;
        u:udrec;
    begin
      knt:=0; needbox:=true;
      for cnt:=1 to numuds do begin
        seekudfile (cnt);
        read (udfile,u);
    if wildcardmatch (wildcard,u.filename) then begin
      if needbox then begin
                                writeln;
                topfileline;
                needbox:=false;
              end;
          listfile (cnt,false);
      inc(knt); inc(totalcnt);
        end;
        if xpressed then exit
      end;
      if not needbox then begin
            bottomfileline;
            writeln(^S+strr(knt)+^P' file(s) found.'^R);
            writeln;
            end;
    end;

    procedure totalmatch;
    begin
    writeln; writeln(^S+strr(totalcnt)+^P+' matches found.');
    end;

    procedure searchareatext (t:anystr);
    var cnt,knt:integer;
    u:udrec;
    b,needbox:boolean;
    begin
      needbox:=true; knt:=0;
      for cnt:=1 to numuds do begin
        b:=false;
        seekudfile (cnt);
        read (udfile,u);
       if pos(upstring(t),upstring(u.filename))>0 then b:=true;
        if pos(upstring(t),upstring(u.extdesc))>0 then b:=true;
        if pos(upstring(t),upstring(u.programname))>0 then b:=true;
    if b then begin
            if needbox then begin writeln; topfileline; end;
            listfile (cnt,false);
            needbox:=false;
            inc(knt); inc(totalcnt);
          end;
        if xpressed then exit;
      end;
      if not needbox then begin
            bottomfileline;
            writeln(^S+strr(knt)+^P+' files found.'^R);
            writeln;
             end;
    end;


  begin
    writeln;
    totalcnt:=0;
    writestr ('Look in all areas? '^S'[y/n]'^R': *');
    searchall:=yes;
    writeln;
    begin
     writestr (^R'Enter '^P'TEXT'^R' to search for:');
     writeln;
     if length(input)=0 then exit;
     stext:=input;
     if not searchall then begin
       writeln(^P'Looking for "'^S+stext+^P'" in current area.');
       searchareatext(stext);
       totalmatch;
       exit;
       end;
     for cntt:=1 to numareas do begin
       seekafile (cntt);
       read (afile,a);
       if urec.udlevel>=a.level then begin
     setarea (cntt);
     writeln;
     writeln(^R'Searching for "'^S+stext+^R'" in ['^P,cntt,^R'] '+^S+area.name+^R'.');
     searchareatext (stext);
     if xpressed then exit;
     end;
     end;
     totalmatch;
    end;
  end;

  procedure addresidentfile (fname:lstr);
  var ud:udrec;
      pointv:longint;
      ccr:lstr;
  begin
    getpathname (fname,ud.path,ud.filename);
    if match(fname,'USERS') then begin
     writelog (16,10,unam);
     writeln (^G'SECURITY VIOLATION!  Paging Sysop.'^M);
     exit;
    end;
    getfsize(ud);
   {pointv:=pointvalue;
    pointv:=pointv*1000;}
    ud.points:=(ud.filesize div pointvalue div 1024);
    if ud.filesize=-1 then begin
     if not offliney then begin
      writeln ('File can''t be opened!');
      exit
     end;
    end;
    writestr (^P'File Size: '^S+strlong(ud.filesize)+^P' Point Value ['^S+strr(ud.points)+^P']:');
    if length(input)=0 then input:=strr(ud.points);
    ud.points:=valu(input);
    if ud.points<0 then ud.points:=0;
    writestr ('Sent by [CR/'+unam+']: &');
    if length(input)=0 then input:=unam;
    ud.sentby:=input;
    ud.when:=now;
    ud.whenrated:=now;
    ud.downloaded:=0;
    buflen:=27;
    writestr ('Program Description: &');
    ud.programname:=input;
    buflen:=2;
    writestr ('Disk Number: &');
    ud.disknum:=valu(input);
    if ud.disknum<1 then ud.disknum:=1;
    buflen:=2;
    writestr ('Total Disks: &');
    ud.totaldisk:=valu(input);
    if ud.totaldisk<1 then ud.totaldisk:=1;
   {writestr ('Description: &');
    ud.descrip:=input;}
    ud.extdesc:=getextdesc;
    if filepw then begin
     buflen:=30;
     writestr ('File Password [CR/None]: &');
     if length(input)=0 then ud.dlpw:='' else
     ud.dlpw:=input;
    end else
    ud.dlpw:='';
    buflen:=30;
    writestr ('Private for: &');
    if length(input)=0 then ud.private:='' else ud.private:=input;
    writestr ('Special Request only? [Ask]: *');
    ud.specialfile:=yes;
    ud.newfile:=false;
    addfile (ud);
    if zipcomment then begin
    writestr ('Add Zip Comment? [y/n]: *');
    if yes then begin
    addcomment (area.xmodemdir,ud.filename);
     end;
    end;
    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:=upstring(input);
    writestr ('Path of File [CR/'+area.xmodemdir+']:');
    fp:=upstring(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;

 {function findfile (str:string):boolean;
  var i:integer;
      i2:integer;
      b:boolean;
  begin
  i2:=curarea;
  i:=1;
  while (numuds>=i) and (b=false) do begin
  seekudfile (i); if exist (datadir+'AREA'+strr(i)+'.'+strr(conn)) then begin
  read (udfile,ud); if (match(ud.filename,str)) then begin
  b:=true; end else b:=false; i:=i+1; end; end;
  i:=1; seekudfile (i2); read (udfile,ud);
  if b=true then writeln (^S+str+^P': '^R'Already exists!');
  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 Multiple 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'    File Cost: '^S,ud.points,
               {^M^J'  Description: '^S,ud.descrip, }
                ^M^J' Program Desc: '^S,ud.programname+' '+strr(ud.disknum)+^R'/'^S+
    strr(ud.totaldisk),
                ^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;
         write (' Private File: '^S);
         if length(ud.private)<1 then writeln ('No') else
         writeln ('Yes  '+ud.private);
        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','QUSNFPVAEDTRC?');
      case q of
        2:getstring ('Uploader',ud.sentby);
       {3:begin
            nochain:=true;
            getstring ('Description',ud.descrip)
          end;}
        3:getboo ('Special Request only',ud.specialfile);
        4:getboo ('New File (unrated)',ud.newfile);
        5:getstring ('Filename',ud.filename);
        6:getstring ('Path',ud.path);
        7:getint ('File Cost',ud.points);
        8:if (not filepw) then writeln ('File Passwords were not configured!')
          else getstringgg ('File Password',ud.dlpw);
        9:ud.extdesc:=getextdesc;
        10:getstring ('Program Description',ud.programname);
        11:begin buflen:=2; getint ('Disk Number',ud.disknum);
           buflen:=2; getint ('Total Disks',ud.totaldisk);
           end;
        12:getstringgg ('Private File',ud.private);
        13:addcomment (ud.path,ud.filename);
        14:begin
           fchangemenu;
           end;

      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'Program Desc:'^S,ud.programname+' '+strr(ud.disknum)+^R'/'^S+
    strr(ud.totaldisk));
    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)+'.'+strr(conn);
    erase (udfile);
    for cnt:=curarea to numareas-1 do begin
      newname:=oldname;
      oldname:='Area'+strr(cnt+1)+'.'+strr(conn);
      assign (udfile,datadir+oldname);
      rename (udfile,datadir+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;
      q:char;
  begin
    a:=area;
    repeat
    clearscr;
    writehdr ('Modify Area');
    writeln(^P'['^S'A'^P'] '^R'Area Name   : '^S+a.name);
    writeln(^P'['^S'B'^P'] '^R'Access Level: '^S+strr(a.level));
    writeln(^P'['^S'C'^P'] '^R'Area Sponsor: '^S+a.sponsor);
    writeln(^P'['^S'D'^P'] '^R'Entry PW    : '^S+a.areapw);
    write  (^P'['^S'E'^P'] '^R'Allow U/Ls  : '^S);
    if a.upload then writeln('Yes') else
    writeln(^S'No');
    write  (^P'['^S'F'^P'] '^R'Allow D/Ls  : '^S);
    if a.download then writeln('Yes') else
    writeln(^S'No');
    if issysop then
    writeln(^P'['^S'G'^P'] '^R'Xfer Path   : '^S+a.xmodemdir+^M);
    writestr (^P'['^R'Area Modify Command'^P']'^S': *');
    if hungupon then exit;
    q:=upcase(input[1]);
    case q of
     'A':begin getstringgg ('Area Name',a.name);
     writelog (16,3,a.name);
      seekafile (curarea);
      write (afile,a);
      area:=a
     end;
     'B':begin getint ('Access Level',a.level);
     writelog (16,11,strr(a.level));
      seekafile (curarea);
      write (afile,a);
      area:=a
     end;
     'C':begin getstringgg ('Sponsor',a.sponsor);
     writelog (16,12,a.sponsor);
      seekafile (curarea);
      write (afile,a);
      area:=a
     end;
     'D':begin getstringgg ('Entry Password',a.areapw);
     writelog (16,18,a.areapw);
      seekafile (curarea);
      write (afile,a);
      area:=a
     end;
     'E':begin getboo ('Able to Upload into area',a.upload);
      seekafile (curarea);
      write (afile,a);
      area:=a
     end;
     'F':begin getboo ('Able to Download from area',a.download);
      seekafile (curarea);
      write (afile,a);
      area:=a
     end;
     'G':if issysop then begin
      a.xmodemdir:=getapath;
      seekafile (curarea);
      write (afile,a);
      area:=a;
      writelog (16,13,a.xmodemdir)
     end;
    end;
  until q='Q';
    seekafile (curarea);
    write (afile,a);
    area:=a
  end;

  procedure sortarea;
  var temp,mark,cnt:integer;
      u1,u2:udrec;
  begin
    writehdr('Sort File Area'); writeln;
    writestr('Are you sure? '+^S+'[y/n]'+^P+':');
    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; sz:real;
      lttp,laym,honkyshide,ocky:anystr;
      damn:file; drive:char; r:registers;

      function unsigned (i:integer):real;
      begin
        if i>=0 then unsigned:=i else unsigned:=65536.0+i
      end;



  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;
    seekudfile (fn);
    read (udfile,ud);
    writelog (16,5,ud.filename);
    laym:=getfname(ud.path,ud.filename);
    ocky:=ud.path;
    write('Moving.');
    setarea (an);
    if (not match(ud.path,area.xmodemdir)) and (pe) then begin
         ud.path:=area.xmodemdir;
         lttp:=getfname(ud.path,ud.filename);
         drive:=upcase(lttp[1]);
        r.ah:=$36; r.dl:=ord(drive)-64;
        intr($21,r);
        if r.ax=$ffff then begin
                writeln;
                writeln('Dest. Drive does not exist!');
                exit;
                end;

        sz:=unsigned(r.bx)*unsigned(r.ax)*unsigned(r.cx); writeln;
    writeln;
writeln('There are ',^S,streal(sz),^R,' bytes free on the '^S,drive,^R,' drive.');
        if sz<=ud.filesize then begin
        writeln;
    writeln('That is not enough space for this file.  You must clear up another');
    writeln(^S,streal(ud.filesize-sz),^R,' bytes to continue.');
        exit;
        end;
            write('Copying.');
         exec(getenv('COMSPEC'),'/C copy '+laym+' '+lttp);
         honkyshide:=laym;

         assign(damn,honkyshide);
         if exist(honkyshide) then erase (damn) else begin
          ud.path:=ocky;
          writeln('ERROR: Unable to move file!');
          end;
    end;
    addfile (ud);
    setarea (oldn);
    removefile (fn);
    writeln(' - 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:=datadir+'Area';
        fn2:=fn1+strr(newa+1)+'.'+strr(conn);
        fn1:=fn1+strr(cura+1)+'.'+strr(conn);
        Assign(f1,fn1);
        Assign(f2,fn2);
        Rename(f1,'TempArea');
        Rename(f2,fn1);
        Rename(f1,fn2);
        close (f1);
        close (f2);
      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>-2 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'Program Desc:',ud.programname+' '+strr(ud.disknum)+'/'^S+
    strr(ud.totaldisk));
            i:=menu ('File Newscan','NEWSCAN','Q#_CEPDTRM0?');
            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 Program Description:');
                      if length(input)>0 then ud.programname:=input;
                      writeudrec
                    end;
                  5:begin
                    writestr ('Enter new Disk Number:');
                    if length(input)>0 then ud.disknum:=valu(input);
                    writeudrec
                    end;
                  6:begin
                    writestr ('Enter new Total Disks Number:');
                    if length(input)>0 then ud.totaldisk:=valu(input);
                    writeudrec
                    end;
                  7:begin
                      renamefile;
                      advance:=0
                    end;
                  8:begin
                      deletef;
                      advance:=0
                    end;
                  9:listarchive (fn);
                 10:begin
                      movefile;
                      advance:=0
                    end;
                 11:begin
                      ratefile (0);
                      done:=true
                    end;
                 12:begin
                    newscanmenu;
                    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 begin doarea; end
    end else begin doarea; end;
    if flag then writeln (^B'No new files.')
  end;

  procedure generatelist;
  var total,a,b,c,x,y,z:integer;
      list:text;
      yoo,ud:udrec;
      s:anystr;
      f:file;
      str1,str2:string;
  begin
   total:=0;
   writehdr ('Generate Master File List');
   writestr ('Make complete list of all files available? [y/n]: *');
   if not yes then exit;
   if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
   assign (list,faqdir+'MASTER.'+strr(conn));
   rewrite (list);
   writeln (list);
   writeln (list,'[Master File List created by FAQ v'+ver+' for '+longname+']');
   writeln (list);
   writeln (list,'Num. Filename     Description');
   writeln (list,'───────────────────────────────────────────────────────────────────────────────');
   for x:=1 to numareas do begin
    setarea (x);
    writeln (list);
    writeln (list,'Area: ',area.name,' [',curarea,']');
    writeln (list);
    for y:=1 to numuds do
    begin
     seekudfile(y);
     read (udfile,yoo);
     total:=total+1;
     write (list,strr(total)+'.');
     for a:=1 to 5-(length(strr(total)+'.')) do write (list,' ');
     write (list,yoo.filename);
     for b:=1 to 13-(length(yoo.filename)) do write (list,' ');
    if exist (getfname(yoo.path,yoo.filename)) then begin
     write (list,strlong(yoo.filesize));
     for c:=1 to 10-(length(strlong(yoo.filesize))) do write (list,' ');
    end else
    write (list,'[Offline] ');
    writeln (list,yoo.programname+' '+strr(yoo.disknum)+'/'+strr(yoo.totaldisk));
    end;
   end;
   writeln (list);
   writeln (list,'- '+strr(total)+' Files Processed');
   writeln (list,'- List generated by FAQ v'+ver);
   textclose (list);
   setarea (1);
   writeln;
   writeln ('Please wait while file is being Zipped up.');
   addtozip (area.xmodemdir+'ALLFILES.ZIP',faqdir+'MASTER.'+strr(conn));
   writeln (usr);
   if not exist (area.xmodemdir+'ALLFILES.ZIP') then begin
    writeln ('Cannot locate temporary Zipfile '+area.xmodemdir+'ALLFILES.ZIP!');
    exit;
   end;
   writeln;
   ud.filename:='ALLFILES.ZIP';
   ud.path:=area.xmodemdir;
   ud.dlpw:='';
   ud.sentby:=unam;
   ud.when:=now;
   ud.whenrated:=now;
   ud.points:=0;
   ud.downloaded:=0;
   ud.newfile:=false;
   ud.specialfile:=false;
   ud.extdesc:='Master file list for '+longname;
   getfsize (ud);
   addfile (ud);
   writeln (^R'Downloading '^S+ud.filename+^R'.');
   download (numuds,false);
   removefile (numuds);
   assign (f,getfname(ud.path,ud.filename));
   erase (f);
   writelog (16,18,unam);
  end;

  procedure extractfile;
  var n:integer;
      ud,scratch:udrec;
      ok,done:boolean;
      effn,master,dir,sname,tempfn:anystr;
  begin
   n:=getfilenum ('Extract from');
   if n=0 then exit;
   seekudfile (n);
   read (udfile,ud);
   ok:=checkok (ud);
   if not ok then exit;
   writeln;
   writeln (^R'Archive Filename: '^S,ud.filename,^R);
   done:=false;
   repeat
    writeln;
    writeln (^R'Enter Filename to extract from Archive, or hit [V] to View.');
    writestr (': *');
    if length(input)=0 then exit;
    if upstring(input)='V' then listarchive (n) else
    done:=true;
   until done or hungupon;
   effn:=upstring(input);
  {setarea (1);}
   dir:=area.xmodemdir;
   if dir[length(dir)]<>'\' then dir:=dir+'\';
   if exist(effn) then begin
     writeln ('File Already Exists!');
     exit;
   end;
   master:=getfname (ud.path,ud.filename);
   extract (effn,master,dir);
   tempfn:=effn;
   effn:=getfname(dir,effn);
   if not exist (effn) then begin
    writeln (^G);
    writeln ('Error! Cannot find extracted file '+effn);
    writeln ('Please notify Sysop!');
    exit;
   end;
   writeln (usr);
   sname:=copy (tempfn,1,(pos ('.',tempfn)));
   writeln ('Please wait while file is being Zipped up.');
   addtozip (dir+sname+'ZIP',effn);
   writeln (usr);
   if not exist (dir+sname+'ZIP') then begin
    writeln ('Cannot locate temporary Zipfile '+dir+sname+'ZIP!');
    exit;
   end;
   scratch.filename:=sname+'ZIP';
   scratch.path:=dir;
   scratch.dlpw:='';
   scratch.sentby:=unam;
   scratch.when:=now;
   scratch.whenrated:=now;
   scratch.points:=1;
   scratch.downloaded:=0;
   scratch.newfile:=false;
   scratch.specialfile:=false;
   scratch.extdesc:='Temporary Zipfile for downloading by '+unam+' ONLY.';
   getfsize (scratch);
   addfile (scratch);
   writeln (^R'Downloading '^S+scratch.filename+^R'.');
   download (numuds,false);
   removefile (numuds);
   writelog (16,19,ud.filename);
  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,'The Flaming Pit');
   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 showinfo (n:integer);
  var ud:udrec;
  begin
   if n>numuds then exit;
   seekudfile (n);
   read (udfile,ud);

  end;

  procedure newscan;
  var cnt,aka,insane:integer;
      u:udrec;
      gnuwarez,done,non:boolean;
      c:char;
  begin
    vcr:=false;
    gnuwarez:=false;
    beenaborted:=false;
    aka:=0;
    cn:=0;
    non:=false;
    repeat
    cn:=0;
    non:=false;
    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
      inc(cn);
      if (cn=18) and (non=false) then
      begin
       bottomfileline;
       cn:=0;
      writestr (^S'CR'^P'/'^R'Next  '^S'+'^P'/'^R'Add to batch  '^S'D'^R'ownload  '^S'N'^R'on-stop  '^S
      +'Q'^R'uit  '^S'V'^R'iew'^P': '^U'*');
      if capfir(input)='A' then addtobatch (0);
      if capfir(input)='D' then download (0,true);
      if capfir(input)='N' then non:=true;
      if capfir(input)='Q' then exit;
      if capfir(input)='V' then listarchive (0);
       writeln;
       topfileline;
      end;

         aka:=aka+1;
         if aka=1 then begin
          clearscr;
          writeln (^R'['^S,curarea,^R']  ['^S,area.name,^R']'^M);
          topfileline;
         end;

         listfile (cnt,false);
         gnuwarez:=true;
        end;
       end;

    if not gnuwarez then done:=true else done:=false;
    if gnuwarez then begin
     c:='N';
     bottomfileline;
     writeln;
     writestr (^P'Newscan Command ['^S'?/Help'^P'] ['^S'CR/Next Area'^P']'^S': '^U'*');
     if length(input)<1 then input:='N';
     c:=input[1];
     insane:=valu(input);
     c:=upcase(c);
     if (insane>0) and (insane<=numuds) then begin
      showinfo (insane);
      writeln;
      writestr ('Hit [Enter]:');
     end else
       c:=upcase(input[1]);
       if length(input)=0 then done:=true else
       case c of
        '?':begin
              writeln;
              writeln (^S'          -File Xfer Newscan Help-'^R^M);
              writeln ('[N]: Next File Area        [I]: More Info on a File ');
              writeln ('[A]: See Files Again       [V]: View a File (ZIP/ARC/PAK/LZH)');
              writeln ('[D]: Download a File       [+]: Add file to Batch');
              writeln ('[Q]: Quit Newscan');
              if sponsoron then begin
               writeln (^S'              -Sysop Commands- '^R);
               writeln ('[C]: Change a File         [!]: Validate all New Files');
               writeln ('[R]: Rename a File         [E]: Delete a File');
              end;
              writeln;
              aka:=0;
              writestr (^M'Hit [Enter] to continue.*');
              aka:=0;
            end;
        '+':begin
             writeln;
             addtobatch (0);
             writestr (^M'Hit [Enter] to continue.*');
             aka:=0;
            end;
        'D':begin
             writeln;
             download (0,true);
             writestr (^M'Hit [Enter] to continue.*');
             aka:=0;
            end;
        'A':begin
             done:=false;
             aka:=0;
            end;
        'V':begin
             writeln;
             listarchive (0);
             writestr (^M'Hit [Enter] to continue.*');
             aka:=0;
            end;
        'Q':begin
             vcr:=true;
             exit;
            end;
        'C':begin
             if not sponsoron then exit;
             changef;
             aka:=0;
            end;
        'R':begin
             if not sponsoron then exit;
             renamefile;
             aka:=0;
            end;
        'E':begin
             if not sponsoron then exit;
             deletef;
             aka:=0;
            end;
        '!':begin
             if not sponsoron then exit;
             newfiles;
             aka:=0;
            end;
        'I':begin
             writeln;
             fileinfo (0);
             aka:=0;
             writestr ('Hit [Enter] to continue.*');
            end;
        'N':done:=true;
       end;
      end;
    until done;
  end;

  procedure newscanall;
  var cnt:integer;
      a:arearec;
  begin
    writeln (^R'Newscanning All Areas - Press ['^S'X'^R'] to Abort.'^M);
    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);
        writeln (^R+area.name+^P' ['^S+strr(curarea)+^P']');
        if aborted or vcr then exit;
        newscan;
      end;
      if aborted then exit
    end;
   writeln (^R^M'Newscan complete!'^G);
  end;


  procedure yourudstats;
  begin
     yourudstatus;
     clearscr;
   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 Transfer Sponsor','FSYSOP','A@CDF@G@KRNSMLO@QEW*@V?');{P}
      case i of
        1:sysopadd;
        2:changef;
        3:deletef;
        4:directory;
        5:offfaq;
        6:killarea;
        7:modarea;
        8:newfiles;
        9:sortarea;
        10:movefile;
        11:listxmodem;
        12:reorderareas;
        14:renamefile;
        15:addmultiplefiles;
        16:getarea;
        17:renameallfiles;
        18:begin
           sponsormenu;
           end;
      end
    until hungupon or (i=13)
  end;

  procedure listfile (n:integer; extended:boolean);
  var ud       :udrec;
      q,xy     :sstr;
      a        :string;
      b        :string;
      c        :string;
      ed       :string;
      desc     :string;
      lamedata :string[1];
      up1      :byte;
      dah      :boolean;
  begin
    seekudfile (n);
    read (udfile,ud);
    write (^S+strr(n));
    spacelen(4-length(strr(n)));
    if ffname in urec.filelister then begin
    write(^S+UPSTRING(copy(ud.filename,1,length(ud.filename)-4)));
    spacelen(9-length(copy(ud.filename,1,length(ud.filename)-4)));
    end;
    if ffext in urec.filelister then begin
    write(^S+upstring(copy(ud.filename,length(ud.filename)-2,3)));
    spacelen(4-length(copy(ud.filename,length(ud.filename)-2,3)));
    end;
    if ffsize in urec.filelister then begin
    if exist (getfname(ud.path,ud.filename)) then begin
    write(^S,strlong(ud.filesize));
    spacelen(10-length(strlong(ud.filesize)));
    end;
    if not exist (getfname(ud.path,ud.filename)) then begin
     write (^P'['^S'Offline'^P'] '^S);
    end;
   end;
    if ffpoints in urec.filelister then begin
    if ud.newfile
          then write (^S'New  ')
          else if length(ud.private)>0
            then write (^S'Priv ')
            else if ud.specialfile
              then write (^S'Ask  ')
              else if ud.points>0
                then begin write (^S+strr(ud.points)); spacelen (5-length(strr(ud.points))) end
                  else if leechweek
                  then write (^S'N/A  ')
                    else write (^S'Free ')
    end;
    if ffuploader in urec.filelister then begin
    write(^S,ud.sentby);
    spacelen(13-length(ud.sentby));
    end;
    if ffuploaded in urec.filelister then begin
    write(^S,datestr(ud.when));
    spacelen(9-length(datestr(ud.when)));
    end;
    if ffdown in urec.filelister then begin
    write(^S,strr(ud.downloaded));
    spacelen(4-length(strr(ud.downloaded)));
    end;
    if fffulnam in urec.filelister then begin
    write (^S,ud.programname);
    spacelen(28-length(ud.programname));
    end;
    if ffofwhat in urec.filelister then begin
    xy:=^S+strr(ud.disknum)+^R'/'^S+strr(ud.totaldisk);
    write (^S,xy);
    spacelen(6-length(xy));
    end;
    writeln;
 if cn>18 then cn:=18;
  {end;}
 end;

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

  Function capfir(inString:STRING):STRING;
 begin
   capfir:=upcase(inString[1]);
 end;

  procedure listfiles (extended:boolean);
  var cnt,max,r1,r2:integer;
      non:boolean;
  begin
    if nofiles then exit;
    clearscr;
    cn:=0;
    non:=false;
    max:=numuds;
    thereare (max,'File','Files');
    parserange (max,r1,r2);
    if r1=0 then exit;
   {writeln;}
   topfileline;
    for cnt:=r1 to r2 do begin
     inc(cn);
       if (cn>=18) and (non=false) then
     begin
      bottomfileline;
      cn:=0;
      writestr (^S'CR'^P'/'^R'Next  '^S'+'^P'/'^R'Add to batch  '^S'D'^R'ownload  '^S'N'^R'on-stop  '^S
      +'Q'^R'uit  '^S'V'^R'iew'^P': '^U'*');
      if capfir(input)='A' then addtobatch (0);
      if capfir(input)='D' then download (0,true);
      if capfir(input)='N' then non:=true;
      if capfir(input)='Q' then exit;
      if capfir(input)='V' then listarchive (0);
      topfileline;
     end;
      listfile (cnt,extended);
      if break then exit
    end;
  bottomfileline;
  end;

var i,c,kkk1,kkk2,oldarea:integer;
    a:arearec;
    ms:boolean;
    z:integer;
    x1,x2,x3:integer;
    y1,y2,y3:real;
    xferlist:text;
    temp:file;
label ok,exit2;
begin
  urec.averagecps:=baudrate div 10;
  vcr:=false;
  cursection:=udsysop;
  ms:=false;
  if (x3<xferpcr) and (ulvl<pcrexempt) then begin
  writeln ('File Access Denied!');
  writeln ('Your PCR is lower than the required PCR in the setup.');
  goto exit2; end;
  writehdr ('File Transfer Section');
  input:='';
  if exist ('BATCH.'+strr(conn)) then begin
   assign (temp,datadir+'BATCH.'+strr(conn));
   erase (temp);
  end;
  assign (batfile,datadir+'BATCH.'+strr(conn));
  close (batfile);
  reset (batfile);
  if ioresult<>0 then rewrite (batfile);
  assign (afile,datadir+'Areadir'+'.'+strr(conn));
  if exist (datadir+'Areadir'+'.'+strr(conn)) then
      begin
        reset (afile);
        if filesize (afile)>0 then goto ok
      end
    else rewrite (afile);
  getconpw;
  writeln ('No transfer areas exist!');
  area.xmodemdir:=faqdir+'XFER\';
  if issysop
    then if makearea
      then goto ok;
  goto exit2;
  ok:
  seekafile (1);
  read (afile,a);
  if urec.udlevel<a.level then begin
    writeln ('Sorry, you can''t access the first area!');
    goto exit2
  end;
  writeln;
  if exist(textfiledir+'FILENEWS.'+strr(conn)) then begin
  printfile (textfiledir+'FILENEWS.'+strr(conn));
  pause;
  end;
  x3:=percent(urec.nbu,urec.numon);
  yourudstats;
  setarea(1);
  repeat
    if withintime (xmodemclosetime,xmodemopentime) then
      if not issysop then begin
      printxy(42,12,^S+'Transfer section closed.'+^R);
        goto exit2
      end else if not ms then begin
        ms:=true
      end;
      write (^B);
      writeln (^R'Conference #'^S+strr(conn)+' '+area.name+^P' ['^S+strr(curarea)+^P']');
    if sponsoron or issysop
      then writeln (^R'['^S'%'^R']:Xfer Sponsor Commands');
    oldarea:=curarea;
    i:=menu ('File Transfer','FILE','UDLWYA*SQ%NVRFXTEGB+ZJ?');
    if hungupon then goto exit2;
    case i of
      1:upload;
      2:download (0,true);
      3:listfiles (false);
      4:sendmailto (area.sponsor,false);
      5:yourudstats;
      6,7:getarea;
      8:begin;
        searchfile;
        setarea(oldarea);
    end;
      10:sysopcommands;

      11:begin;
        newscanall;
        setarea(oldarea);
     end;
      12:begin;
        newscan;
        setarea(oldarea);
     end;
      13:listarchive (0);
      14:{whoup;}configurefilelisting;
      15:xtendedlist;
      16:typefile;
      17:requestfile;
      18:generatelist;
      19:batchmenu;
      20:addtobatch (0);
      21:extractfile;
      22:begin changecon('X'); close (afile); close (udfile); close (batfile); i:=ioresult;
      erase (batfile); assign (xferlist,textfiledir+'Xferlist.FAQ');
  if exist (textfiledir+'Xferlist.FAQ') then erase (xferlist); udsection; exit; end;
      23:begin
         xfermenu;
         end;
    end
  until hungupon or (i=9);
  exit2:
  close (afile);
  close (udfile);
  close (batfile);
  i:=ioresult;
  erase (batfile);
  assign (xferlist,textfiledir+'Xferlist.FAQ');
  if exist (textfiledir+'Xferlist.FAQ') then erase (xferlist);
end;

begin
end.