Jason Aller Floppy Collection/276.img/FORUM21S.ZIP/FILEXFER.PAS

Pascal/Delphi Source File | 1988-03-27 | 38KB | 1,515 lines

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

unit filexfer;

interface

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

procedure udsection;

implementation

procedure udsection;

var ud:udrec;
    area:arearec;
    curarea:integer;

  procedure beepbeep (ok:integer);
  begin
    delay (500);
    write (^B^M);
    case ok of
      0:write ('Done');
      1:write ('Aborted just before EOF');
      2:write ('Aborted')
    end;
    writeln ('!'^G^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 for '+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? *');
        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 for '+unam+']:');
      if length(input)=0 then input:=unam;
      a.sponsor:=input;
      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,'!')
    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;
    assignud;
    close (udfile);
    reset (udfile);
    if ioresult<>0 then rewrite (udfile);
    writeln (^B^M'Active: '^S,area.name,' [',curarea,']');
    if sponsoron then writeln ('%: Sponsor commands');
    writeln
  end;

  procedure listareas;
  var a:arearec;
      cnt:integer;
  begin
    writehdr ('Area List');
    seekafile (1);
    for cnt:=1 to numareas do begin
      read (afile,a);
      if a.level<=urec.udlevel
        then writeln (cnt:2,'. (',a.level,') ',a.name);
      if break then exit
    end
  end;

  function getareanum:integer;
  var areastr:sstr;
      areanum:integer;
  begin
    getareanum:=0;
    if length(input)>1
      then areastr:=copy(input,2,255)
      else
        repeat
          writestr (^M'Area # [?=list]:');
          if input='?' then listareas else areastr:=input
        until (input<>'?') or hungupon;
    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;
  begin
    seekudfile (n);
    read (udfile,ud);
    tab (strr(n)+'.',4);
    tab (ud.filename,14);
    if ud.newfile
      then write ('New  ')
      else if ud.specialfile
        then write ('Ask  ')
        else if ud.points>0
          then tab (strr(ud.points),5)
          else write ('     ');
    tab (strlong(ud.filesize),10);
    writeln (ud.descrip);
    if break or (not extended) then exit;
    write ('    ');
    tab (datestr(ud.when),19);
    tab (strr(ud.downloaded),10);
    writeln (ud.sentby)
  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'^M);
    max:=numuds;
    thereare (max,'file','files');
    parserange (max,r1,r2);
    if r1=0 then exit;
    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 ('You may not transfer 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'Newscan aborted!')
    end
  end;

  procedure newscan;
  var cnt:integer;
      u:udrec;
  begin
    beenaborted:=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 listfile (cnt,false)
    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 for 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);
    if tpath[length(tpath)]<>'\' then tpath:=tpath+'\';
    tpath:=tpath+'*.*';
    writestr ('Path/wildcard [CR for '+tpath+']:');
    writeln (^M);
    if length(input)<>0 then tpath:=input;
    writelog (16,10,tpath);
    findfirst (chr(defaultdrive+64)+':\*.*',8,ffinfo);
    if doserror<>0
      then writeln ('No volume label'^M)
      else writeln ('Volume label: ',ffinfo.name,^M);
    findfirst (tpath,$17,ffinfo);
    if doserror<>0 then writeln ('No files found.') else begin
      cnt:=0;
      while doserror=0 do begin
        cnt:=cnt+1;
        if not break then displayfile (ffinfo);
        findnext (ffinfo)
      end;
      writeln (^B^M'Total files: ',cnt)
    end;
    write ('Free disk space: ');
    writefreespace (tpath)
  end;

  procedure listarchive;
  var n:integer;
      ud:udrec;
      f:file of byte;
      fname:lstr;
      b:byte;
      sg:boolean;
      size:longint;

    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;
    writehdr ('Archive File List');
    repeat
      read (f,b);
      if b<>26 then begin
        badarchive;
        exit
      end;
      read (f,b);
      if b=0 then begin
        close (f);
        exit
      end;
      sg:=false;
      for n:=1 to 13 do begin
        read (f,b);
        if b=0 then sg:=true;
        if sg then b:=32;
        write (chr(b))
      end;
      size:=getsize;
      for n:=1 to 6 do read (f,b);
      writeln ('   ',getsize);
      seek (f,filepos(f)+size)
    until break or hungupon
  end;

  procedure download (autoselect:integer);
  var totaltime:sstr;
      num,fsize,mins:integer;
      ud:udrec;
      fname:lstr;
      ymodem:boolean;
      b:integer;
      f:file;
  begin
    if not allowxfer then exit;
    if nofiles then exit;
    if autoselect=0
      then num:=getfilenum('download')
      else num:=autoselect;
    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 tempsysop then begin
      ulvl:=regularlevel;
      tempsysop:=false;
      writeurec;
      bottomline
    end;
    ymodem:=false;
    writestr ('X)modem or Y)modem? *');
    if length(input)>0 then ymodem:=upcase(input[1])='Y';
    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);
    close (f);
    totaltime:=minstr(fsize);
    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!');
      exit
    end;
    if (mins-5>timetillevent) then begin
      writestr ('Sorry, the timed event is coming up too soon!');
      exit
    end;
    writeln (^B^M'Filename:       '^S,ud.filename);
    writeln ('Uploaded by:    '^S,ud.sentby);
    write ('Downloaded:     '^S,ud.downloaded,' time');
    if ud.downloaded=1 then writeln else writeln ('s');
    if ymodem then fsize:=(fsize+7) div 8;
    writeln ('Blocks to send: '^S,fsize);
    writeln ('Transfer time:  '^S,totaltime);
    writeln (^M'CRC use will be automatically selected');
    writeln (^B'Press [Ctrl-X] to abort the transfer'^B);
    b:=protocolxfer (true,false,ymodem,fname);
    beepbeep (b);
    if (b=0) or (b=1) then begin
      writelog (15,1,fname);
      ud.downloaded:=ud.downloaded+1;
      urec.downloads:=urec.downloads+1;
      seekudfile (num);
      write (udfile,ud);
      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
  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 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 upload;
  var ud:udrec;
      ok,crcmode,ymodem:boolean;
      b:integer;
      fn:lstr;
  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;
    ok:=false;
    write ('Free disk space: ');
    writefreespace (area.xmodemdir);
    writeln;
    repeat
      writestr ('Target 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 ('Sorry!  File exists!')
        else ok:=true
    until ok;
    ymodem:=false;
    writestr ('X)modem or Y)modem? *');
    if length(input)>0 then ymodem:=upcase(input[1])='Y';
    if ymodem then crcmode:=true else begin
      writestr ('CRC Mode? *');
      crcmode:=yes
    end;
    write (^B^M);
    if ymodem then write ('Y') else write ('X');
    write ('MODEM');
    if crcmode then write ('-CRC');
    writeln (' receive ready.  [Ctrl-X] Aborts');
    if tempsysop then begin
      ulvl:=regularlevel;
      tempsysop:=false;
      writeurec;
      bottomline
    end;
    b:=protocolxfer(false,crcmode,ymodem,fn);
    beepbeep (b);
    if b=0 then begin
      writelog (15,2,ud.filename);
      buflen:=40;
      writestr ('Description of upload: &');
      ud.descrip:=input;
      ud.sentby:=unam;
      ud.when:=now;
      ud.whenrated:=now;
      ud.points:=0;
      ud.downloaded:=0;
      ud.newfile:=true;
      ud.specialfile:=false;
      ud.downloaded:=0;
      writeln ('Thanks for uploading!');
      getfsize (ud);
      addfile (ud);
      urec.uploads:=urec.uploads+1;
      newuploads:=newuploads+1
    end;
  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? *');
    searchall:=yes;
    writestr ('File name (wildcards OK):');
    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;
  begin
    writeln (^B^M'Access level:    '^S,urec.udlevel,
               ^M'Transfer points: '^S,urec.udpoints,
               ^M'Uploads:         '^S,urec.uploads,
               ^M'Downloads:       '^S,urec.downloads)
  end;

  procedure newscanall;
  var cnt:integer;
      a:arearec;
  begin
    writehdr ('Newscanning... 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 then exit;
        newscan
      end;
      if aborted then exit
    end
  end;

  procedure addresidentfile (fname:lstr);
  var ud:udrec;
  begin
    getpathname (fname,ud.path,ud.filename);
    getfsize(ud);
    if ud.filesize=-1 then begin
      writeln ('File can''t be opened!');
      exit
    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;
    writestr ('Special request only? *');
    ud.specialfile:=yes;
    ud.newfile:=false;
    addfile (ud);
    writelog (16,8,fname)
  end;

  procedure sysopadd;
  var fn: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 ('Name/path of file:');
    fn:=input;
    if exist(fn)
      then
        begin
          writestr ('Confirm: '+fn+' (Y/N):');
          if yes then addresidentfile (fn)
        end
      else writeln ('File not found!')
  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);
    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 req: '^S,yesno(ud.specialfile),
                ^M^J'    Sent by: '^S,sentby,
                ^M^J'    Sent on: '^S,datestr(when),
                ^M^J'    Sent at: '^S,timestr(when),^M^J);
    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','QUDSNFPV');
      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)
      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:integer;
      fn:lstr;
      ud:udrec;
      f:file;
  begin
    n:=getfilenum ('delete');
    if n=0 then exit;
    seekudfile (n);
    read (udfile,ud);
    fn:=getfname(ud.path,ud.filename);
    writelog (16,7,fn);
    writestr ('Confirm: File '+fn+' ('+ud.descrip+') ? *');
    if not yes then exit;
    removefile (n);
    writestr ('Erase disk file '+fn+'? *');
    if not yes then exit;
    assign (f,fn);
    erase (f)
  end;

  procedure killarea;
  var a:arearec;
      cnt,n:integer;
      oldname,newname:sstr;
  begin
    writestr ('Delete area #'+strr(curarea)+' ('+area.name+')? *');
    if not yes then exit;
    writelog (16,2,'');
    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);
    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;
  begin
    oldn:=curarea;
    fn:=getfilenum ('move');
    if fn=0 then exit;
    input:='';
    an:=getareanum;
    if an=0 then exit;
    writeln ('Moving...');
    seekudfile (fn);
    read (udfile,ud);
    writelog (16,5,ud.filename);
    removefile (fn);
    setarea (an);
    addfile (ud);
    setarea (oldn);
    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                          Lvl Pts'^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),4);
          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 to 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);
    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
            writeln ('Granting ',ud.sentby,' ',p,' points.');
            if un=unum then writeurec;
            seek (ufile,un);
            read (ufile,u);
            u.udpoints:=u.udpoints+p;
            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 ('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? *');
      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 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@');
      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
      end
    until hungupon or (i=13)
  end;

var i:integer;
    a:arearec;
    ms:boolean;
label ok,exit;
begin
  cursection:=udsysop;
  ms:=false;
  writehdr ('The 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 areas have been defined!');
  area.xmodemdir:=forumdir+'XMODEM\';
  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;
  yourudstatus;
  setarea (1);
  repeat
    if withintime (xmodemclosetime,xmodemopentime) then
      if not issysop then begin
        writestr (^M^M'Sorry, the XMODEM 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 XMODEM section is closed until ',xmodemopentime,')');
        ms:=true
      end;
    write (^B^M^M,area.name,' [',curarea,']'^B);
    i:=menu('File','FILE','UDLFYA*SQ%NVHRWXT');
    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
    end
  until hungupon or (i=9);
  exit:
  close (afile);
  close (udfile);
  i:=ioresult
end;


begin
end.