Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/SYSPC22.ZIP/FILEXFER.PAS

Pascal/Delphi Source File | 1989-02-14 | 37.4 KB | 1,493 lines

overlay procedure udsection;

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

  procedure beepbeep (ok:integer);
  begin
    write (^B^M);
    case ok of
      0:write ('Done');
      1:write ('Aborted just before EOF');
      2:write ('Aborted')
    end;
    writeln ('!');
  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:regs;
      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 or (urec.udlevel>=sysoplevel);
  end;

function convtime(blxs:integer):integer;

var c,d:integer;
    e,f,k:real;
    g:integer;

begin
k:=(BLXS*1.0);
c:=BAUDrate;
e:=(c*0.8);
c:=trunc(e);
CONVTIME:=trunc (k/((e/10)*60)*128);

end;
  function getapath:lstr;
  var q,r:integer;
      f:file;
      b:boolean;
      p:lstr;
  begin
    getapath:=area.xmodemdir;
    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;
      writestr ('Allow Uploads:');
      a.upload:=yes;
      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);
  begin
    curarea:=n;
    if (n>numareas) or (n<1) then begin
      writeln (^B'No such area: ',n,'!');
      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
            reqlevel (area.level);
            setarea (1);
            exit
          end;
    assignud;
    close (udfile);
    reset (udfile);
    if ioresult<>0 then rewrite (udfile);
    writeln (^B^M'File Area: [',curarea,']:[',area.name,']');
    if sponsoron then writeln ('%: Sponsor commands');
    writeln
  end;

  procedure listareas;
  var a:arearec;
      cnt:integer;
  begin
    writehdr ('Area List');
    seekafile (1);
    writeln ('[Area]   [Level]      [Name]');
    for cnt:=1 to numareas do begin
      read (afile,a);
      if a.level<=urec.udlevel
        then begin
        write ('[',cnt:2,']     [',a.level:5,']      ');
        tab ('['+a.name,26);
        writeln (']');
        end;
      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 begin
        listareas;
        repeat
          writestr (^M'Area # [?=list]:');
          if input='?' then listareas else areastr:=input
        until (input<>'?') or hungupon;
        end;
    if length(areastr)=0 then exit;
    areanum:=valu(areastr);
    if (areanum>0) and (areanum<=numareas)
      then getareanum:=areanum
      else begin
        writestr ('No such area!');
        if issysop then if makearea then getareanum:=numareas
      end
  end;

  procedure getarea;
  var areanum:integer;
  begin
    areanum:=getareanum;
    if areanum<>0 then setarea (areanum)
  end;

 function getfname (path:lstr; name:mstr):lstr;
  var l:lstr;
  begin
    l:=path;
    if length(l)<>0
      then if not (upcase(l[length(l)]) in [':','\'])
        then l:=l+'\';
    l:=l+name;
    getfname:=l
  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 nofiles:boolean;
  begin
    if numuds=0 then begin
      nofiles:=true;
      writestr (^M'Sorry, no files!')
    end else nofiles:=false
  end;

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

   overlay procedure listfiles (uploader:boolean; n:integer);
  var cnt,max,r1,r2:integer;

    procedure listfile (n:integer; uploader:boolean);
    var ud:udrec;
         q:sstr;
  begin
    seekudfile (n);
    read (udfile,ud);
    tab (strr(n)+'.',4);
    if break then exit;
    tab (ud.filename,14);
    if break then exit;
     if ud.newfile then
     write ('New  ');
     if ud.points>0
          then tab (strr(ud.points),5)
          else write ('Free ');
    if break then exit;
    if ud.specialfile
        then tab ('Offline',10)
      else if ud.sysfile then
        tab ('SysOp',10)
        else
          if exist (ud.path+ud.filename) then tab (streal(ud.filesize),10) else
        tab ('Offline',10);
    if break then exit;
    if uploader
     then writeln (ud.sentby)
      else writeln (ud.descrip)
  end;



  begin
    if nofiles then exit;
    if n>0 then begin
    listfile (n,uploader);
    exit;
    end;
    writehdr ('File List'^M);
    max:=numuds;
    thereare (max,'file','files');
    parserange (max,r1,r2);
    if r1=0 then exit;
    write ('#   ');
    tab ('Filename',14);
    write ('Pts. ');
    tab ('Filesize',10);
    if uploader then writeln ('Uploader') else writeln ('Description');
    writeln ('[---------------------------------------------------------------------------]');
    for cnt:=r1 to r2 do begin
      listfile (cnt,uploader);
      if break then exit
    end
  end;

  overlay 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;


overlay 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;

  overlay procedure directory;
  type dosstr=array [1..100] of char;
       ffinfotype=record
         reserved:array [1..21] of byte;
         attrib:byte;
         time,date,fsizelow,fsizehi:integer;
         name:dosstr
       end;
  var r:regs;
      ffinfo:ffinfotype;

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

  var tpath:anystr;
      b:byte;
      fname:sstr;
      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;
    dos_shell ('dir '+tpath+' > temp.txt');
    if exist ('temp.txt') then printfile ('temp.txt')
    else writeln ('*> Shell Error. Code: ',shell_return_code,' <*');
  end;



  overlay function doext (mode,proto:char;uddir,fn:lstr;baud,comm:integer):integer;
  var cmdline,dirsave,cddir:anystr;
      baudst,commst:mstr;
      retcd:integer;
  begin
    getdir (0, dirsave);   (* drive: 0 = cur. 1 = A: etc. - save cur. dir. *)
    cddir:=copy(uddir,1,length(uddir)-1);
    chdir (cddir);                (* cd to rcv/snd dir *)
    if mode='R' then begin        (* receive stuff *)
      case proto of
        'Z':cmdline:=dirsave+'\DSZ port '+strr(comm)+' speed '+strr(baud)+' restrict rz';
        'W':cmdline:=dirsave+'\WXMODEM -b '+strr(baud)+' -l com'+strr(comm)+' -p W -r -f '+fn+' -c';
        'S':cmdline:=dirsave+'\CLINK R';
        'M':cmdline:=dirsave+'\MLINK PORT '+strr(comm)+' SPEED '+strr(baud)+' RM'
      end
    end;
    if mode='S' then begin        (* xmit stuff *)
      case proto of
        'Z':cmdline:=dirsave+'\DSZ port '+strr(comm)+' speed '+strr(baud)+' sz '+fn;
        'W':cmdline:=dirsave+'\WXMODEM -s -b '+strr(baud)+' -l com'+strr(comm)+' -p y -f '+fn;
        'S':cmdline:=dirsave+'\CLINK T '+fn;
        'M':cmdline:=dirsave+'\MLINK PORT '+strr(comm)+' SPEED '+strr(baud)+' SM '+fn
      end
    end;
    dos_shell (cmdline);         (* actually do external call... *)
    chdir (dirsave);                (* back from whence we came... *)
    doext:=shell_return_code;
  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:=longfilesize(df);
    close(df)
  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,0);
          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;





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

  label done;
  begin
    if nofiles then exit;
    n:=getfilenum('list');
    if n=0 then exit;
    seekudfile (n);
    read (udfile,ud);
    fname:=getfname(ud.path,ud.filename);
    dos_shell (arcview+' '+fname+' >temp.txt');
    if exist ('temp.txt') then printfile ('temp.txt')
    else writeln ('*> Archive View Error <*');
  end;



  overlay procedure download (autoselect:integer);
  var totaltime:sstr;
      extra,num,fsize,mins:integer;
      ud:udrec;
      fname:lstr;
      ymodem:boolean;
      i,b:integer;
      f:file;
      extrnproto:char;
      x1,x2,x3:integer;
      y1,y2,y3:real;



  begin
  if not allowxfer then exit;
x1:=urec.uploads;
x2:=urec.downloads;
if x1<1 then x1:=1;
if x2<1 then x2:=1;
   y1:=int(x1);
   y2:=int(x2);
   y1:=y1;
   y2:=y2;

   y3:=y1/y2;
   Y3:=Y3*100;
  x3:=trunc(y3);

if udratio >0 then
  if (X3<udratio) and not issysop and (ulvl<nopcr) then begin
  dontstop:=true;
  nobreak:=true;
  if exist (textfiledir+'udratio') then printfile (textfiledir+'udratio') else begin
  writeln (^T'          *> Upload/Download Ratio <*');
  writeln ('      You''ve uploaded ',urec.uploads,' files');
  writeln ('      And have downloaded ',urec.downloads,' files.');
  writeln ('      You have a ',x3,'% ratio now.');
  writeln ('      Minimum Ratio is ',udratio,'%.');
  Writeln (^M' Your Upload/Download ratio is too low,Post a message or two!');
  end;
  exit;
  end;
    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 ('*> Not enough file points <*');
      exit
    end;
    if (ud.newfile) and (not sponsoron) then begin
      writeln ('*> Un-Validated File <*');
      exit
    end;
    if (ud.specialfile) and (not sponsoron) then begin
      writeln ('*> File Offline. Request using [F] command <*');
      exit
    end;
    if (ud.sysfile) and (not sponsoron) then begin
      writeln ('*> Must be a SysOp/Sponsor to download <*');
      exit
    end;
    if not exist (ud.path+ud.filename) then begin
      writeln ('*> Error: File Offline. Inform Sysop <*');
      exit
    end;
    if tempsysop then begin
      ulvl:=regularlevel;
      tempsysop:=false;
      writeurec;
      bottomline
    end;
    ymodem:=false;
    extrnproto:='N';
    i:=menu('Protocol','PROTO','XYZBWMSQ');
    if hungupon then exit;
    case i of
      1:ymodem:=false;
      2:ymodem:=true;
      3:extrnproto:='Z';
      4:;(***
      begin
          extrnproto:='B';
          ymodem:=true end
          ***)
      5:extrnproto:='W';
      6:extrnproto:='M';
      7:extrnproto:='S';
      8:exit;
    end;
    fname:=getfname(ud.path,ud.filename);
    assign (f,fname);
    reset (f);
    iocode:=ioresult;
    if iocode<>0 then
      begin
        fileerror ('DOWNLOAD',fname);
        exit
      end;
    fsize:=filesize(f);
    close (f);
    totaltime:=minstr(fsize);
    mins:=valu(copy(totaltime,1,pos(':',totaltime)));
    extra:=convtime(fsize);
if (extra  > timeleft) and (not sponsoron) then begin
      writeln ('*> Not Enough Time Left <*');
      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;
    if (extrnproto='Z') and (baudrate=2400) then fsize:=fsize div 4;
    if (extrnproto='Z') and (baudrate=1200) then fsize:=fsize div 2;
    if (extrnproto='M') then fsize:=fsize div 4;
    if fsize = 0 then fsize:= 1;
    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);
    if extrnproto='N' then begin
      b:=protocolxfer (true,false,ymodem,fname);
      beepbeep (b)
    end;
    if extrnproto<>'N' then begin
      b:=doext('S',extrnproto,ud.path,ud.filename,baudrate,usecom);
      if b<>0 then b:=2;
      modeminlock:=false;
      beepbeep (b)
    end;
    if (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;


  overlay procedure upload;
  var ud:udrec;
      ok,crcmode,ymodem:boolean;
      i,b,sm,fd:integer;
      fn,sf:lstr;
      extrnproto:char;

  begin
    if not allowxfer then exit;
    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;
    writestr ('Description of File: &');
    ud.descrip:=input;
    crcmode:=false;
    ymodem:=false;
    extrnproto:='N';
    i:=menu('Protocol','PROTO','XYZBWMSQ');
    if hungupon then exit;
    case i of
      1:ymodem:=false;
      2:ymodem:=true;
      3:extrnproto:='Z';
      4:;(*** begin
          extrnproto:='B';
          ymodem:=true;
        end;
        ***)
      5:extrnproto:='W';
      6:extrnproto:='M';
      7:extrnproto:='S';
      8:exit;
    end;
    if extrnproto='N' then if ymodem then crcmode:=true else begin
      writestr ('CRC Mode? *');
      crcmode:=yes
    end;
    write (^B^M);
    write ('*> ');
    if extrnproto='Z' then write ('Z');
    if extrnproto='W' then write ('WX');
    if ymodem then write ('Y') else if extrnproto='N' then write ('X');
    case extrnproto of
      'M':write ('MegaLink');
      'S':write ('SEALink');
      else write ('modem')
    end;
    if crcmode then write ('-CRC');
    if extrnproto='B' then write ('-Batch');
    writeln (' receive ready.  Press [Ctrl-X] to abort <*');
    if tempsysop then begin
      ulvl:=regularlevel;
      tempsysop:=false;
      writeurec;
      bottomline
    end;
    sf:=timestr;
    sm:=timeval(sf);
    if extrnproto='N' then begin
      b:=protocolxfer (false,crcmode,ymodem,fn);
      beepbeep (b)
    end;
    if extrnproto<>'N' then begin
      b:=doext('R',extrnproto,ud.path,ud.filename,baudrate,usecom);
      modeminlock:=false;
      modemoutlock:=false;
      beepbeep (b)
    end;
    sf:=timestr;
    fd:=timeval(sf);
    if b=0 then begin
      writelog (15,2,ud.filename);
      buflen:=40;
      if fd>sm then urec.timetoday:=urec.timetoday+(fd-sm);
      if sm>fd then urec.timetoday:=urec.timetoday+10;
      ud.sentby:=unam;
      ud.sentda:=datestr;
      ud.sentti:=timestr;
      ud.points:=0;
      ud.downloaded:=0;
      ud.newfile:=true;
      ud.specialfile:=false;
      ud.sysfile:=false;
      ud.downloaded:=0;
      writeln ('Thanks for uploading!');
      getfsize (ud);
      addfile (ud);
      urec.uploads:=urec.uploads+1;
      newuploads:=newuploads+1;
      writestatus;
    end
  end;

      Overlay procedure SortArea;
    var Recs:Array [1..1000] of String[15];
        LastPos:Array [1..1000] of Integer;
        Swap:String[15];
        U:UDRec;
        OldUDFile,NewUDFile:File of UDRec;
        Cnt,Cnt2,Swap2:Integer;

      Function Nums:Integer;
      begin
        Nums:=FileSize(OldUDFile);
      end;

    begin
      Close(UDFile);
      writeln;
      writestr('Sort area? *');
      if not yes then exit;
      Assign(OldUDFile,'Area'+strr(curarea));
      Assign(NewUDFile,'Area'+strr(Curarea)+'.New');
      if Nums>1000 then begin
        writeln('Sorry.. Too many files..');
        exit;
      end;
      reset(OldUDFile);
      For Cnt:=1 to Nums do begin
        Seek(OldUDFile,Cnt-1);
        read(OldUDFile,U);
        Recs[Cnt]:=U.Filename;
        LastPos[Cnt]:=Cnt;
      end;
      For Cnt:=1 to Nums-1 do
        For Cnt2:=Cnt+1 to Nums do begin
          if upstring(Recs[Cnt])>upstring(Recs[Cnt2]) then begin
          Swap:=Recs[Cnt];
          Swap2:=LastPos[Cnt];
          Recs[Cnt]:=Recs[Cnt2];
          LastPos[Cnt]:=LastPos[Cnt2];
          Recs[Cnt2]:=Swap;
          LastPos[Cnt2]:=Swap2;
        end;
      end;
    Close(OldUDFile);
    Reset(OldUDFile);
    Rewrite(NewUDFile);
    For Cnt:=1 to Nums do begin
      seek(OldUDFile,LastPos[Cnt]-1);
      read(OldUDFile,U);
      seek(NewUDFile,Cnt-1);
      write(NewUDFile,U);
    end;
    close(NewUDFile);
    close(OldUDFile);
    erase(OldUDFile);
    rename(NewUDFile,'Area'+Strr(Curarea)+'.');
    writeln;
    writeln('Sort complete.');
    reset(UDFile);
  end;






  overlay procedure yourudstatus(a:integer; heh:boolean);
  var x1,x2,x3:integer;
      y1,y2,y3:real;



  begin

   if (not heh) or (not ansi) or (not urec.windows) then 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);
    exit;
  end;

  windowit (30,8,6,2);
  movexy (10,3);
  writeln ('File Transfer Section');
  movexy (8,5);
  writeln ('Current Xfer Level: '^S,urec.udlevel);
  movexy (15,6);
  writeln ('Xfer Points: '^S,urec.udpoints);
  movexy (19,7);
  writeln ('Uploads: '^S,urec.uploads);
  movexy (17,8);
  writeln ('Downloads: '^S,urec.downloads);
  windowit (28,6,33,7);
  movexy (43,8);
  writeln ('# of Calls: '^S,urec.numon);
  movexy (43,9);
  writeln ('# of Posts: '^S,urec.nbu);
  movexy (36,10);
  writeln ('Current P/C Ratio: '^S,a,'%');
  movexy (36,11);
  writeln ('Minimum P/C Ratio: '^S,xferratio,'%');
  windowit (32,4,37,3);
  movexy (39,4);
x1:=urec.uploads;
x2:=urec.downloads;
if x1<1 then x1:=1;
if x2<1 then x2:=1;
   y1:=int(x1);
   y2:=int(x2);
   y1:=y1;
   y2:=y2;

   y3:=y1/y2;
   Y3:=Y3*100;
  x3:=trunc(y3);
  writeln ('Current U/L D/L Ratio: '^S,x3,'%');
  movexy (39,5);
  writeln ('Minimum U/L D/L Ratio: '^S,udratio,'%');
  movexy (1,14);
  end;



  overlay 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 listfiles (false,cnt)
      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
      end
    end
  end;

  overlay procedure sysopcommands;

    procedure getstr (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);
      getstr (t,s);
      i:=valu(s)
    end;

    procedure getboo (t:lstr; var b:boolean);
    var s:sstr;
    begin
      s:=yesno (b);
      getstr (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 sysopadd;
    var ud:udrec;
        fn:lstr;
    begin
      writehdr ('Add Resident File');
      buflen:=12;
      writestr ('Name of file:');
      if length(input)=0 then exit;
      ud.filename:=input;
      writestr ('        Path:');
      if length(input)=0 then exit;
      ud.path:=input;
      if ud.path[length(ud.path)]<>'\' then ud.path:=ud.path+'\';
      fn:=getfname(ud.path,ud.filename);
      writestr ('Confirm: '+fn+' (Y/N):');
      if not yes then exit;
      getfsize(ud);
      if ud.filesize=-1 then begin
        writeln ('File can''t be opened!');
      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.sentda:=datestr;
      ud.sentti:=timestr;
      ud.downloaded:=0;
      writestr ('Description: &');
      ud.descrip:=input;
      writestr ('Special request only? *');
      ud.specialfile:=yes;
      writestr ('Sysop File? *');
      ud.sysfile:=yes;
      ud.newfile:=false;
      addfile (ud);
      writelog (16,8,fn)
    end;

    procedure changef;
    var n:integer;
        ud:udrec;
    begin
      n:=getfilenum ('Change');
      if n=0 then exit;
      seekudfile (n);
      read (udfile,ud);
      writelog (16,4,ud.filename);
      getstr ('filename',ud.filename);
      getstr ('path',ud.path);
      getfsize(ud);
      if ud.filesize=-1 then writestr ('Warning:  Can''t open file!');
      getint ('points',ud.points);
      getstr ('uploader',ud.sentby);
      getstr ('time sent',ud.sentti);
      getstr ('date sent',ud.sentda);
      nochain:=true;
      getstr ('description',ud.descrip);
      getboo ('special request only',ud.specialfile);
      getboo ('sysop file',ud.sysfile);
      getboo ('new file (unrated)',ud.newfile);
      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;
      getstr ('area name',a.name);
      writelog (16,3,a.name);
      getint ('access level',a.level);
      writelog (16,11,strr(a.level));
      getstr ('sponsor',a.sponsor);
      writelog (16,12,a.sponsor);
      getboo ('allow uploads',a.upload);
      if issysop then begin
        a.xmodemdir:=getapath;
        writelog (16,13,a.xmodemdir)
      end;
      seekafile (curarea);
      write (afile,a);
      area:=a
    end;

    procedure newfiles (makelist:boolean);
    var a,fn,p,un:integer;
        ud:udrec;
        u:userrec;
        flag:boolean;
        other:integer;

      procedure doarea;
      begin
        for fn:=1 to numuds do begin
          seekudfile (fn);
          read (udfile,ud);
          if ud.newfile then begin
            flag:=false;
            listfiles (false,fn);
            if true then begin
              writestr (^M'How many points for '+ud.filename+' [CR to continue]: @');
              if length(input)<>0 then begin
                p:=valu(input);
                ud.points:=p;
                ud.newfile:=false;
                seekudfile (fn);
                write (udfile,ud);
                p:=p*uploadfactor;
                if p>0 then begin
                  un:=lookupuser (ud.sentby);
                  if un=0
                    then writeln (ud.sentby,' has vanished!')
                    else begin
                writestr ('Points to grant '+ud.sentby+' [CR for '+strr(p)+']: @');
                      if (length(input)>0) then p:=valu(input);
                      writeln (^M'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
            end
          end
        end
      end;

    label exit;
    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);
            doarea
          end;
          goto exit
        end
      end;
      doarea;
      exit:
      if flag then writeln (^B'No new files.')
    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 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;

  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@Q');
      case i of
        1:sysopadd;
        2:changef;
        3:deletef;
        4:directory;
{        5:generatelist; }
        6:killarea;
        7:modarea;
        8:newfiles (false);
        9:sortarea;
        10:movefile;
        11:;
        12:reorderareas
      end
    until hungupon or (i=13)
  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;
      first:integer;
  label notlater;
  begin
    beenaborted:=false;
    first:=0;
    for cnt:=filesize(udfile) downto 1 do begin
      seekudfile (cnt);
      read (udfile,u);
      if later (u.sentda,u.sentti,lastonda,lastonti)
        then first:=cnt
        else goto notlater
    end;
    notlater:
    if first<>0
      then for cnt:=first to filesize(udfile) do begin
        if aborted then exit;
        listfiles (false,cnt)
      end
  end;

  procedure newscanall;
  var cnt:integer;
      a:arearec;
  begin
    writehdr ('Newscanning... press [X] to abort.');
    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;

var prompt:lstr;
    n:integer;
    k:char;
    x1,x2,x3,i:integer;
    y1,y2,y3:real;
    q1:mstr;
    a:arearec;
    ms:boolean;
    dammit:boolean;

label ok,exit;
begin
dammit:=false;
x1:=urec.nbu;
x2:=urec.numon;
if x1<1 then x1:=1;
if x2<1 then x2:=1;
   y1:=int(x1);
   y2:=int(x2);
   y1:=y1;
   y2:=y2;

   y3:=y1/y2;
   Y3:=Y3*100;
  x3:=trunc(y3);

    IF ANSI THEN ANSICLS;
if xferratio >0 then
  if (X3<xferratio) and not issysop and (ulvl<nopcr) then begin
  dontstop:=true;
  nobreak:=true;
  if exist (textfiledir+'XFratio') then printfile (textfiledir+'XFratio') else begin
  writeln (^T'          *> Post/Call Ratio <*');
  writeln ('      You''ve posted ',urec.nbu,' messages');
  writeln ('      And have called ',urec.numon,' times.');
  writeln ('      You have a ',x3,'% ratio now.');
  writeln ('      Minimum Ratio is ',xferratio,'%.');

  Writeln (^M' Your Posts/Call ratio is too low,Post a message or two!');
  end;
  dammit:=true;
  end;
  if dammit then goto exit;
  cursection:=udsysop;
  ms:=false;
  if (not urec.windows) or (not ansi) then writeln   ('       *> 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 ('*> Access level too low <*');
    goto exit
  end;
  yourudstatus(x3,true);
  setarea (1);
  repeat
    if not withintime (xmodemopentime,xmodemclosetime) then
      if not issysop then begin
        writestr (^M^M'Sorry, the Transfer section is closed now!');
        writeln ('The time now is: '^S,timestr);
        writeln ('It will open at: '^S,xmodemopentime);
        goto exit
      end else if not ms then begin
        writeln ('(The Transfer section is closed until ',xmodemopentime,')');
        ms:=true
      end;
    write (^B^M^M,'[',curarea,'] [',area.name,']'^B);
    i:=menu('File','FILE','UDLFYA*SQ%NVHRW_');
    if hungupon then goto exit;
    case i of
      1:if area.upload then upload else
        Writeln ('*> Uploads not allowed in this area <*');
      2:download (0);
      3:listfiles (false,0);
      4:sendmailto (area.sponsor,false);
      5:yourudstatus(0,false);
      6,7:getarea;
      8:searchfile;
      10:sysopcommands;
      11:newscanall;
      12:newscan;
      13:;
      14:listarchive;
      15:listfiles (true,0);
      16:;
    end
  until hungupon or (i=9);
  exit:
  close (afile);
  close (udfile);
  i:=ioresult
end;