Jason Aller Floppy Collection/270.img/FORUM25C.ZIP/FILEXFER.PAS

Pascal/Delphi Source File | 1989-02-26 | 41KB | 1,563 lines

{Filexfer Externals protocol revision 2.1d}
{$R-,S-,I-,V-,B-,L+ }
{$O+,F+}
{$M 65500,0,0 }

unit filexfer;

interface

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

procedure udsection;

implementation

procedure udsection;

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


(* Note: This Code has the added External Protocols by Mr. Transistor & by  *)
(* Spring King.  The original code is written by Ken Duda.  The new code is *)
(* written by Spring King & Mr. Transistor.  There is 1 new feature in this *)
(* version:  in an external protocal transfer, a time credit of 1/2 of the  *)
(* time of the upload is given the user.  Ymodem & Xmodem use a different   *)
(* formula, which can be modified in the file 'protocol.pas'.               *)
(* This code is written to include the megalink and protocol too, but       *)
(* but the menu selections 'M' is disabled because of a problem setting     *)
(* the modem back up after using MegaLink.  If you are going to use Sealink *)
(* you must have your modem setup as COM1 or else Sealink will NOT work.    *)
(* Thanks to Omen Technologies (DSZ) and to whoever wrote Wxmodem, Sealink, *)
(* and Megalink.                                                            *)
(* Special thanks to Spring King, Mr. Transistor, and Ken Duda, the author  *)
(* of Forum PC.                                                             *)
(* call the Isengard BBS [phone]                                     *)

  procedure runext (var ret_code:integer; var command_line,switches:lstr);
  begin
   Writeln(USR,Command_line+switches);
{   exec(command_line,switches); }
   ret_code := DOS_Exec(Command_line+switches,FALSE,FALSE);
   if Ret_code<>0 then
      begin
      writeln;
      writeln;
      writestr(^G^G^G);
      fileerror ('EXTERNPROTOCOL',command_line+switches);
      writeln;
      writestr('Press Enter to Continue... *');
      read;
      ret_code:=2;
    end
  End;

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 setareareset (n:integer);

  begin
    curarea:=n;
    seekafile (n);
    read (afile,area);
    assignud;
    close (udfile);
    reset (udfile);
    if ioresult<>0 then rewrite (udfile);
    writeln
  end;

procedure listareas;
  var a:arearec;
      cnt:integer;
  begin
    if exist (textfiledir+'arealist.ans') then
      begin
        printfile (textfiledir+'arealist');
        exit;
      end
    else if issysop then begin
      writeln ('To create a file list, create 3 files in the Forum TEXTFILE');
      writeln ('directory called arealist and append the appropriate suffixes');
     end;
    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,13);  {adds a space}
    if ud.newfile
      then write ('New ')
      else if ud.specialfile
        then write ('Ask ')
        else if ud.points>0
          then tab (strr(ud.points),4)
          else write ('    ');
    tab (strlong(ud.filesize),8); {2 spaces}
    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 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;

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;

  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;

function getfilenumbatch (t:mstr):integer;
  var n,s:integer;
  begin
    getfilenumbatch:=0;
    if length(input)>1 then input:=copy(input,2,255) else
      repeat
        writestr ('File name/number to '+t);
        writestr ('[?=List *=Change Area $=Search]:');
        if hungupon or (length(input)=0) then exit;
        if input='?' then begin
          listfiles (false);
          input:='';
        end;
        if input='$' then begin
          searchfile;
          input:='';
        end;
        if input='*' then begin
          getarea;
          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 getfilenumbatch:=n;
      if t='Batch Transfer' then input:='';
  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;
      if t='Batch Transfer' then input:='';
  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;


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
    if t=('description') then {the following is for the change file description only}
    buflen:=50;            {limits sysop input to 50 chars}
    if t=('description') then
      writeln  (^R'       Old description: '^S,q);

    if t=('description') then begin
      writestr ('                        0        1         2         3         4         5');
      writestr ('50 Characters Maximum!  1---!----0----!----0----!----0----!----0----!----0');
    end
    else writeln ('Old ',t,': ',q);
    writestr ('Enter new '+t+' :');
    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;
      Temp : INTEGER;

    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;
    repeat
     n:=getfilenum('list');
     if n=0 then exit;
     seekudfile (n);
     read (udfile,ud);
     fname:=getfname(ud.path,ud.filename);
     if (pos ('.ZIP',fname)=0) and (pos ('.zip',fname)=0) then begin
        writeln (^M^J'That file does NOT appear to be an ARCHIVE file.  Please enter a');
        writeln ('different filename or 0 to abort.');
        end;
    until (pos ('.ZIP',fname)<>0) or (pos ('.zip',fname)<>0);
    if exist ('arclist.bat') then
     begin
      writeln (^S'Creating Archive list');
      TEMP := DOS_exec ('c:\command.com /C c:arclist.bat '+fname+' '+textfiledir+'arclist.',FALSE,FALSE);
                                                  {I assume you keep }
                                                  {command.com in the Root of}
                                                  {of drive C:.  If not, change}
      if ioresult <>0 then begin
        iocode:=ioresult;
        fileerror ('LISTARCHIVE',FNAME);
        end
      else begin
          writeln (^R);
          printfile (textfiledir+'arclist');
          end;
      exit;
      end;
    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;

{$I TRANSFER.PAS}  {Reads in the file Transfer.pas, which contains all the}
                   {Download & Upload subroutines}



  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;
    buflen:=50;
    writestr ('                   0        1         2         3         4         5');
    writestr ('50 Characters Max! 1---!----0----!----0----!----0----!----0----!----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');
    setareareset (curarea);
    writeln ('The default path is: '^S,area.xmodemdir);
    writeln;
    writestr ('Enter a new path or RETURN to use the default:');
    if length(input)=0 then spath:=area.xmodemdir
    else spath:=input;
    pathpart:=spath;
    writestr ('Enter the wildcards or a filename:');
    if length(input)=0 then spath:=spath+'*.*'
    else spath:=spath+input;
    if pathpart[length(pathpart)]='\' then dec(pathpart[0]);
    assign (f,pathpart+'\con');
    reset (f);
    if ioresult<>0 then begin
      close (f);
      exit;
      end
    else close (f);
    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','QUDSNFPRV');
      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:showudrec (ud);
        9: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 ZipSortarea;
  var temp,mark,cnt:integer;
      u1,u2:udrec;
  begin
    writehdr ('Zip Sort Area');
    writestr ('Confirm (Y/N):');
    if not yes then exit;
    mark := numuds-1;
    if mark=0 then Exit;
    temp := numuds-1;
    mark := 0;
    writeln(temp);
    for cnt := 1 to temp do
      begin
        seekudfile (cnt);
        read (udfile,u1);
        mark := Pos('.ARC',UpString(u1.filename));
        If mark <> 0 THEN
          Begin
            delete(u1.filename,mark,4);
            u1.filename := UpString(u1.filename)+'.ZIP';
            Writeln(u1.filename);
          End;
        seekudfile(cnt);
        write(udfile,u1)
      End;
  end;

  procedure movefile;
  var an,fn,oldn:integer;
      zn,cddir,dirsave,dirsave1,p:lstr;
      ud:udrec;
      mbatchf,batchf,batchf1:text;
      f:file;
      Temp : INTEGER;
    begin
    getdir (0, dirsave);
    oldn:=curarea;
    if area.xmodemdir[length(area.xmodemdir)]='\'
    then
    cddir:=copy(area.xmodemdir,1,length(area.xmodemdir)-1)
    else
    cddir:=area.xmodemdir;
    chdir (cddir);
    getdir (0, dirsave1);
    chdir (dirsave);
    fn:=getfilenum ('move');
    if fn=0 then exit;
    input:='';
    seekudfile (fn);
    read (udfile,ud);
    writelog (16,5,ud.filename);
    zn:=getfname(ud.path,ud.filename);
    p:=ud.filename;
    writeln;
    writeln ('File '+zn+'');
    an:=getareanum;
    setarea (an);
    writestr ('Shall I move '+p+' from directory '+ud.path+' to File Area '+input+'');
    writeln;
    if area.xmodemdir[length(area.xmodemdir)]<'\'
    then
    cddir:=copy(area.xmodemdir,1,length(area.xmodemdir)-1)
    else
    cddir:=area.xmodemdir;
    writestr ('and directory '+cddir+' ? (Y/N): *');
    writeln;
    if not yes then begin
      setarea (oldn);
      chdir (dirsave);
      exit;
    end;
    chdir (dirsave1);
    cddir:=area.xmodemdir;
    if ud.path=cddir then begin
    if area.xmodemdir[length(area.xmodemdir)]>'\'
    then
    ud.path:=copy(ud.path,1,length(ud.path)-1)
    else
    ud.newfile:=false;
    addfile (ud);
    chdir (dirsave);
    setarea (oldn);
    removefile (fn);
    exit
    end;
    assign (mbatchf,'mov.bat');
    rewrite (mbatchf);
    writeln (mbatchf,'echo off');
    writeln (mbatchf,'if not exist %1 goto whoops1');
    writeln (mbatchf,'copy %1 %2');
    writeln (mbatchf,'if not exist %2 goto whoops2');
    writeln (mbatchf,'del %1');
    writeln (mbatchf,'goto end');
    writeln (mbatchf,':whoops1');
    writeln (mbatchf,'echo Move failed. File not found !');
    writeln (mbatchf,'goto end');
    writeln (mbatchf,':whoops2');
    writeln (mbatchf,'echo Move failed. File not erased from original directory !');
    writeln (mbatchf,':end');
    textclose (mbatchf);
    assign (batchf, 'move1.bat');
    rewrite (batchf);
    writeln (batchf,'echo off');
    if area.xmodemdir[length(area.xmodemdir)]='\'
    then
    cddir:=copy(area.xmodemdir,1,length(area.xmodemdir)-1)
    else
    cddir:=area.xmodemdir;
    writeln (batchf,'mov.bat ',zn,' ',cddir,'\',p);
    textclose (batchf);
    Temp := DOS_exec('c:\command.com /c move1.bat',FALSE,FALSE);
    setparam(usecom,baudrate,parity);
    assign (f,'move1.bat');
    erase (f);
    assign (f,'mov.bat');
    erase (f);
    if area.xmodemdir[length(area.xmodemdir)]>'\'
    then
    ud.path:=copy(area.xmodemdir,1,length(area.xmodemdir)-1)
    else
    ud.path:=area.xmodemdir;
    ud.newfile:=false;
    getfsize(ud);
    if ud.filesize=-1 then begin
    writestr ('I can''t open the file in current directory! Continue? (Y/N): *');
    if not yes then exit
    end;
    addfile (ud);
    chdir (dirsave);
    setarea (oldn);
    removefile (fn);
    writeln;
    writeln (^B'The file has been moved from the current area & directory!');
  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
                      buflen:=50;
                      writestr ('                       0        1         2         3         4         5');
                      writestr ('    50 Characters Max! 1---!----0----!----0----!----0----!----0----!----0');
                      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 1 minute after: '^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%NVHREWXTZ');
    if hungupon then goto exit;
    case i of
      1:upload;
      2:download (0);
      3:listfiles (false);
      4:sendmailto (LookUpUser(area.sponsor),false);
      5:yourudstatus;
      6,7:getarea;
      8:searchfile;
      10:sysopcommands;
      11:newscanall;
      12:newscan;
      13:help ('Filexfer.hlp');
      14:listarchive;
      15:if exist (textfiledir+'arclist') then printfile (textfiledir+'arclist')
         else writestr ('You must first list the contents of an archive file before you can RELIST it!');
      16,17:listfiles (true);
      18:typefile;
      19 : {ZipSortArea} ;
    end
  until hungupon or (i=9);
  exit:
  close (afile);
  close (udfile);
  i:=ioresult
end;


begin
end.