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

Pascal/Delphi Source File | 1991-05-04 | 73.9 KB | 2,396 lines

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

unit protocol;

interface

uses dos,crt,video,
     configrt,gentypes,modem,statret,windows,gensubs,subs1,subs2,mainr2,
     userret;

type btchuparray=array [1..100] of mstr;

var totaltime      :sstr;
    cn             :byte;
    bat2           :string;
    mins           :integer;
    status         :word;
    curarea        :integer;
    totpoints      :word;
    xtype          :char;
    a              :arearec;
    protrec        :protorec;

procedure wipedszlog;
procedure laterdays;
procedure runext (var ret_code:integer; var commandline,switchz:lstr);
function doext(mode,proto:char; uddir,fn:lstr; baud,comm:integer):integer;
procedure beepbeep (ok:integer);
function checkdszlog (fnxfered:anystr):char;
function sponsoron:boolean;
procedure seekudfile (n:integer);
procedure requestfile;
function getfname (path:lstr; name:mstr):lstr;
procedure possiblelzm (points:integer);
function checkok (ud:udrec):boolean;
function searchforfile (f:sstr):integer;
procedure listfile (n:integer; extended:boolean);
procedure listfiles (extended:boolean);
function allowxfer:boolean;
function numuds:integer;
function nofiles:boolean;
function getfilenum (t:mstr):integer;
function numb:integer;
function totalxfersize:longint;
function totalxfertime:integer;
procedure addtobatch (auto:integer);
procedure downbatch;
procedure upbatch;
procedure listbatch;
procedure clearbatch;
procedure listprotocols (t:integer);
procedure batchmenu;
procedure askaboutbye;
procedure showhisstats;
function findprot(rors,prot:char):boolean;
function cmdline (f:lstr):lstr;
function switches (c,fn:lstr):lstr;
procedure avrcps;
procedure fchangemenu;
procedure newscanmenu;
procedure sponsormenu;
procedure xfermenu;

implementation

function protocolxfer (send,crcmode,ymodem:boolean; fn:lstr):integer;
{ Return codes:  0=OK, 1=Cancelled within last three blocks, 2=Aborted }

{% ENDIF}

  const can=^X; ack=^F; nak=^U; soh=^A; stx=^B; eot=^D; crcstart='C';

  var timedout:boolean;

  function tenthseconds:integer;
  var r:registers;
  begin
    r.ah:=$2c;
    intr ($21,r);
    tenthseconds:=(r.dh*10)+(r.dl div 10)
  end;

  function fromnow (tenths:integer):integer;
  begin
    tenths:=tenthseconds+tenths;
    if tenths>599 then tenths:=tenths-600;
    fromnow:=tenths
  end;

  function timeout (en:integer):boolean;
  begin
    timeout:=(en=tenthseconds) or hungupon
  end;

  procedure clearmodemahead;
  var k:char;
  begin
    while numchars>0 do k:=getchar
  end;

  procedure wait (tenths:integer);
  begin
    tenths:=fromnow (tenths);
    repeat until timeout (tenths) or hungupon
  end;

  function waitchar (tenths:integer):char;
  begin
    waitchar:=#0;
    tenths:=fromnow (tenths);
    repeat
      if numchars>0 then begin
        waitchar:=getchar;
        timedout:=false;
        exit
      end
    until timeout (tenths) or hungupon;
    timedout:=true
  end;

  procedure computecrc (var block; blocksize:integer; var outcrc:word);
  var cnt,c2:integer;
      crc,b:word;
      blk:array[1..1030] of byte absolute block;
      willbecarry:boolean;
  begin
    crc:=0;
    for cnt:=1 to blocksize do begin
      b:=blk[cnt];
      for c2:=1 to 8 do begin
        willbecarry:=(crc and $8000)=$8000;
        crc:=(crc shl 1) or (b shr 7);
        b:=(b shl 1) and 255;
        if willbecarry then crc:=crc xor $1021
      end
    end;
    outcrc:=crc
  end;

(****
    inline (
             $1E/                    {           PUSH  DS               }
             $C5/$B6/block/          {           LDS   SI,[BP+block]    }
             $8B/$96/blocksize/      {           MOV   DX,[BP+blocksize]}
             $31/$DB/                {           XOR   BX,BX            }
             $FC/                    {           CLD                    }
             $AC/                    { Mainloop: LODSB                  }
             $B9/$08/$00/            {           MOV   CX,0008          }
             $D0/$E0/                { Byteloop: SHL   AL,1             }
             $D1/$D3/                {           RCL   BX,1             }
             $73/$04/                {           JNC   No_xor           }
             $81/$F3/$21/$10/        {           XOR   BX,1021          }
             $E2/$F4/                { No_xor:   LOOP  Byteloop         }
             $4A/                    {           DEC   DX               }
             $75/$ED/                {           JNZ   Mainloop         }
             $89/$9E/crc/            {           MOV   [BP+crc],BX      }
             $1F                     {           POP   DS               }
           );
****)

  procedure computecksum (var data; blocksize:integer; var outcksum:byte);
  var t:array [1..1024] of byte absolute data;
      cnt,q:integer;
  begin
    q:=0;
    for cnt:=1 to blocksize do q:=q+t[cnt];
    outcksum:=q and 255
  end;

  procedure showerrorstats (curblk,totalerrs,consec:integer);
  var x:integer;
      r:real;
  begin
    x:=wherex;
    write (usr,totalerrs);
    gotoxy (x,wherey+1);
    write (usr,consec,' ');
    gotoxy (x,wherey+1);
    if curblk+totalerrs<>0 then begin
      r:=round(10000.0*totalerrs/(curblk+totalerrs))/100.0;
      write (usr,r:0:2,'%    ')
    end
  end;

  function xymodemsend (ymodem:boolean):integer;
  var f:file;
      b:array [1..1026] of byte;
      blocksize:integer;
      fsize,curblk,totalerrs,consec,blocksatatime:integer;
      k:char;
      firstblock:boolean;

    function getctrlchar:char;   { Gets ACK/NAK/CAN }
    var k,k2:char;
        cnt:integer;
    begin
      getctrlchar:=can;
      repeat
        cnt:=0;
        repeat
          k:=waitchar (10);
          cnt:=cnt+1;
          if keyhit then begin
            k2:=bioskey;
            if k2=^X then exit;
            timedout:=true
          end
        until (not timedout) or (cnt=60);
        if timedout or hungupon then exit;
        if (k in [ack,nak,crcstart,can]) then begin
          getctrlchar:=k;
          if k=can then sendchar (can);
          exit
        end
      until hungupon;
      timedout:=true
    end;

    procedure sendendoffile;
    var k:char;
        tries:integer;
    begin
      tries:=0;
      repeat
        tries:=tries+1;
        sendchar(eot);
        k:=waitchar (20);
      until (k=ack) or (k=can) or (tries=3);
      sendchar(eot)
    end;

    procedure getblockfromfile;
    begin
      fillchar (b,sizeof(b),26);
      blockread (f,b,blocksatatime);
      blocksize:=blocksatatime shl 7
    end;

    procedure buildfirstblock;
    var cnt,p:integer;
    begin
      blocksize:=128;
      fillchar(b,128,0);
      p:=length(fn);
      repeat
        p:=p-1
      until (p=0) or (fn[p]='\');
      for cnt:=1 to length(fn)-p do b[cnt]:=ord(fn[cnt+p])
    end;

    procedure sendblock (num:integer);
    var cnt,bksize:integer;
        crc:word;
        n:byte;
        k:char;
    begin
      clearmodemahead;
      n:=num and 255;
      if blocksize=1024
        then k:=stx
        else k:=soh;
      if crcmode
        then
          begin
            b[blocksize+1]:=0;
            b[blocksize+2]:=0;
            computecrc (b,blocksize+2,crc);
            b[blocksize+1]:=hi(crc);
            b[blocksize+2]:=lo(crc);
            bksize:=blocksize+2;
          end
        else
          begin
            b[blocksize+1]:=0;
            computecksum (b,blocksize,b[blocksize+1]);
            bksize:=blocksize+1
          end;
      sendchar (k);
      sendchar (chr(n));
      sendchar (chr(255-n));
      for cnt:=1 to bksize do sendchar(chr(b[cnt]))
    end;

    procedure updatestatus;
    begin
      gotoxy (16,3);
      write (usr,curblk,' of ',fsize);
      gotoxy (16,4);
      write (usr,minstr((fsize-curblk)*blocksatatime),' of ',totaltime,' ');
      gotoxy (16,5);
      showerrorstats (curblk,totalerrs,consec)
    end;

    procedure initxfer;
    begin
      starttimer (numminsxfer);
      if ymodem then blocksatatime:=8 else blocksatatime:=1;
      fsize:=(filesize(f)+blocksatatime-1) div blocksatatime;
      totaltime:=minstr(fsize*blocksatatime);
      totalerrs:=0;
      consec:=0;
      firstblock:=true;
      if ymodem
        then
          begin
            curblk:=0;
            buildfirstblock
          end
        else
          begin
            curblk:=1;
            getblockfromfile
          end;
      splitscreen (8);
      top;
      write (usr,'Waiting for NAK')
    end;

    procedure setupscreen;
    begin
      gotoxy (1,1);
      if ymodem then write (usr,'Y') else write (usr,'X');
      write (usr,'modem');
      if crcmode then write (usr,'-CRC');
      writeln (usr,' send in progress.  Press [Ctrl-X] to Abort.');
      clreol;
      gotoxy (1,3);
      writeln (usr,'Current block:');
      writeln (usr,'Time left:');
      writeln (usr,'Total errors:');
      writeln (usr,'  Consecutive:');
      write (usr,'Error rate:')
    end;

  label abort,done;
  begin
    xymodemsend:=2;
    assign (f,fn);
    reset (f);
    iocode:=ioresult;
    if iocode<>0 then exit;
    initxfer;
    repeat
      k:=getctrlchar;
      if k=can then begin
        if (curblk>(fsize*3/4)) and (curblk>2)
          then xymodemsend:=1; { Cheater! }
        goto abort
      end;
      if firstblock then begin
        if (k=nak) or (k=crcstart) then firstblock:=false;
        crcmode:=k=crcstart;
        setupscreen;
        k:=#0
      end;
      if k=ack then begin
        curblk:=curblk+1;
        if eof(f) then goto done;
        getblockfromfile
      end;
      if k<>nak then consec:=0 else begin
        totalerrs:=totalerrs+1;
        consec:=consec+1
      end;
      sendblock(curblk);
      updatestatus
    until 0=1;
    done:
    sendendoffile;
    xymodemsend:=0;
    abort:
    close (f);
    unsplit;
    stoptimer (numminsxfer)
  end;

  function xymodemreceive(ymodem:boolean):integer;
  var f:file;
      block:array [1..1026] of byte;
      blkl,blkh,xblkl,nblkl,nblk1:byte;
      curblk:integer;
      ctrl,k,k2:char;
      timeul,consec,totalerrs,blocksize:integer;
      canceled,timeout:boolean;

    procedure cancel;
    begin
      wait (10);
      clearmodemahead;
      sendchar (can);
      wait (10);
      clearmodemahead;
      sendchar (can);
      canceled:=true
    end;

    function writeblock:boolean;
    var wb:boolean;
    begin
      blockwrite (f,block,blocksize div 128);
      wb:=ioresult=0;
      writeblock:=wb;
      if not wb then begin
        gotoxy (1,1);
        write (usr,'I/O ERROR ',iocode,' WRITING BLOCK');
        clreol;
        sendchar (can);
        wait (10);
        sendchar (can);
        clearmodemahead
      end
    end;

    procedure updatestatus;
    begin
      curblk:=blkl+(blkh shl 8);
      gotoxy (16,3);
      write (usr,curblk);
      gotoxy (16,4);
      showerrorstats (curblk,totalerrs,consec)
    end;

    function sendctrl:char;
    var cnt,consec:integer;
        k:char;
    begin
      cnt:=0;
      consec:=0;
      timeout:=false;
      updatestatus;
      sendctrl:=can;
      repeat
        if keyhit then begin
          k:=bioskey;
          if k=^X then begin
            timeout:=true;
            cancel;
            exit
          end
        end;
        sendctrl:=waitchar (50);
        if not timedout then exit;
        sendchar (ctrl);
        cnt:=0;
        consec:=consec+1
      until (consec=10) or hungupon;
      timeout:=true
    end;

    function getachar:char;
    var cnt:integer;
        k:char;
    begin
      getachar:=#0;
      timeout:=timeout or hungupon;
      if timeout then exit;
      timeout:=false;
      if keyhit then begin
        k:=bioskey;
        if k=^X then begin
          getachar:=#0;
          timeout:=true;
          cancel;
          exit
        end
      end;
      getachar:=waitchar (10);
      timeout:=timeout or timedout
    end;

    procedure xfererror (txt:lstr);
    begin
      gotoxy (16,7);
      write (usr,txt,' in block ',curblk);
      clreol
    end;

    procedure initxfer;
    var k:char;
    begin
      timeul:=timer;
      timeout:=false;
      consec:=0;
      blkl:=1;
      blkh:=0;
      xblkl:=1;
      curblk:=1;
      totalerrs:=0;
      if crcmode
        then ctrl:=crcstart
        else ctrl:=nak;
      canceled:=false;
      starttimer (numminsxfer);
      splitscreen (8);
      top;
      gotoxy (1,1);
      if ymodem then write (usr,'Y') else write (usr,'X');
      write (usr,'modem');
      if crcmode then write (usr,'-CRC');
      write (usr,' receive in progress.  Press [Ctrl-X] to Abort.'^M^J^J,
             'Current block:'^M^J,
             'Total errors:'^M^J,
             '  Consecutive:'^M^J,
             'Error rate:'^M^J,
             'Error type:');
      while numchars>0 do k:=getchar
    end;

    procedure endoffile;
    begin
      xymodemreceive:=0;
      sendchar (ack);
      wait (10);
      sendchar (ack);
      clearmodemahead
    end;

    function block0:boolean;
    var b0:boolean;
        cnt:integer;
    begin
      b0:=(nblkl=0) and (nblk1=255) and (blkh=0) and (blkl<>255);
      if b0 then begin
        xfererror ('(Receiving block 0...)');
        for cnt:=1 to blocksize do block[cnt]:=ord(getachar);
        ctrl:=ack;
        sendchar (ack)
      end;
      block0:=b0
    end;

    function blocknumerror:boolean;
    var bne:boolean;
    begin
      bne:=(nblkl<>(255-nblk1)) or ((nblkl<>xblkl) and (nblkl<>blkl));
      if bne then xfererror ('Block # '+strr(nblkl)+' not '+strr(255-nblk1)+
                             ' and '+strr(xblkl)+' or '+strr(blkl));
      blocknumerror:=bne
    end;

    function resentnoreason:boolean;
    var rnr:boolean;
        cnt:integer;
    begin
      rnr:=(nblkl<>xblkl) and (nblkl=blkl);
      if rnr then begin
        xfererror ('Block re-sent for no reason');
        for cnt:=1 to blocksize do block[cnt]:=ord(getachar);
        ctrl:=ack;
        sendchar (ack)
      end;
      resentnoreason:=rnr
    end;

    procedure getblockfrommodem;
    var cnt:integer;
    begin
      for cnt:=1 to blocksize do begin
        block[cnt]:=ord(getachar);
        if timeout then exit
      end
    end;

    function badblock:boolean;
    var crc:word;
        cksum,reccksum:byte;
    begin
      badblock:=false;
      if crcmode
        then
          begin
            computecrc(block,blocksize,crc);
            if crc<>0 then begin
              xfererror ('CRC error');
              badblock:=true
            end
          end
        else
          begin
            reccksum:=block[129];
            block[129]:=0;
            computecksum(block,blocksize,cksum);
            if cksum<>reccksum then begin
              xfererror ('Checksum error');
              badblock:=true
            end
          end
    end;

  label nakit,abort,done;
  begin
    xymodemreceive:=2;
    assign (f,fn);
    rewrite (f);
    iocode:=ioresult;
    if iocode<>0 then begin
      fileerror ('XYMODEMRECEIVE',fn);
      exit
    end;
    initxfer;
    repeat
      k:=sendctrl;
      ctrl:=nak;
      if timeout or (k=can) then goto abort;
      if k=eot then begin
        endoffile;
        goto done
      end;
      case k of
        soh:blocksize:=128;
        stx:blocksize:=1024
        else begin
          xfererror ('SOH error: '+strr(ord(k)));
          goto nakit
        end
      end;
      if crcmode
        then blocksize:=blocksize+2
        else blocksize:=blocksize+1;
      nblkl:=ord(getachar);
      nblk1:=ord(getachar);
      if timeout then goto nakit;
      if block0 then goto nakit;
      if blocknumerror then goto nakit;
      if resentnoreason then goto nakit;
      if (nblkl=0) and (blkl=255) then blkh:=blkh+1;
      blkl:=nblkl;
      getblockfrommodem;
      if timeout then goto nakit;
      if badblock then goto nakit;
      ctrl:=ack;
      xblkl:=blkl+1;
      sendchar (ack);
      updatestatus;
      if not writeblock then goto abort;
      consec:=0;
      nakit:
      if hungupon then goto abort;
      if timeout then xfererror ('Time out (short block)');
      if ctrl<>ack then begin
        totalerrs:=totalerrs+1;
        consec:=consec+1;
        repeat
          k:=waitchar (10)
        until timedout;
        if consec>=15 then begin
          sendchar (can);
          goto abort
        end;
        sendchar (ctrl)
      end
    until 0=1;
    abort:
    cancel;
    done:
    close (f); consec:=ioresult;
    if canceled then begin
      erase (f); consec:=ioresult
    end;
    timeul:=timer-timeul;
    if timeul<0 then timeul:=timeul+1440;
    settimeleft (timeleft+timeul*2);
    unsplit;
    stoptimer (numminsxfer)
  end;

begin
  totaltime:='';
  if send
    then protocolxfer:=xymodemsend(ymodem)
    else protocolxfer:=xymodemreceive(ymodem)
end;

  procedure wipedszlog;
  var ff:file of protorec;
  begin
    if exist(dszlogname) then begin
                assign(ff,dszlogname);
                erase(ff);
                  end;
  end;


  function cmdline (f:lstr):lstr;
  begin
  cmdline:=faqdir+f;
  end;

  function switches (c,fn:lstr):lstr;
  var x,y,z,w:string;
      a,s:integer;

  begin
   s:=0;
   x:='';
   y:='';
   z:='';
   w:='';

   repeat
      s:=s+1;
      w:=w+c[s];
   until c[s]=' ';
   delete (c,1,s);

   for a:=1 to length(c) do begin
         x:=copy (c,a,1);
         if x='%' then begin
               y:=copy (c,a+1,1);
                case valu(y) of
                    1:z:=z+strr(usecom);
                    2:z:=z+strr(baudrate);
                    3:z:=z+fn;
                                        4:z:=z+strr(urec.averagecps);
                    end;
               delete (c,a+1,1);
                end else z:=z+x;
   end;
   switches:=z;
  end;

  procedure avrcps;
  begin
  urec.averagecps:=baudrate div 10;
  writeln(^R'Average CPS: '^S,strr(urec.averagecps));
  end;

  procedure showhisstats;
  begin
    writeln;
    writeln(^R'NEW: Transfer Statistics:');
if ascii then
    writeln('────────────────────────────') else
    writeln('----------------------------');

writeln(^R'Uploads:     '^S+strr(urec.uploads)+^R+' ['+^S+streal(urec.upk)+^R+' bytes]');
writeln(^R'Downloads:   '^S+strr(urec.downloads)+^R+' ['+^S+streal(urec.downk)+^R+' bytes]');
writeln(^R'File Points: '^S+strr(urec.udpoints)+^R);
if useqr then begin
calcqr;
writeln(^R'Your QR:     '^S+strr(qr)+^R);
          end;
        avrcps;
    writeln;
  end;


  procedure askaboutbye;
  begin
       writeln;
  writestr(^S'H'^R'angup after batch  '^S'A'+
  ^R'bort  '^S'C'^P'/'^S'R'^R' Start Transfer'^P': '^U'&');
  if length(input)=0 then answer:='X' else answer:=upcase(input[1]);
  writeln;
  end;


  procedure laterdays;
  begin
       write(^S+timestr(now)+^R' Logged off after transfer.');
       forcehangup:=true;
  end;


  procedure runext (var ret_code:integer; var commandline,switchz:lstr);
  begin
   exec (commandline,switchz);
   if doserror<>0 then
    begin
      writeln;
      writeln (^G^G);
      write ('DOS Error #',doserror,' - ');
      case doserror of
           2: writeln('File Not Found');
           3: writeln('Path Not Found');
           else writeln(' Unknown');
           end;
           writeln;
      writeln ('Please report the error number to the Sysop!');
      writeln;
pause;
    end
   else ret_code:=dosexitcode;
  end;

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

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

  function checkwork:integer;
  var r:registers;
      ffinfo:searchrec;
      tpath:anystr;
      b:byte;
      cnt:integer;
  begin
    { getdir (defaultdrive,tpath); }
    tpath:=xferdir+'*.*'; cnt:=0;
    findfirst (tpath,$17,ffinfo);

while doserror=0 do begin

if not break then if ffinfo.name[1]<>'.' then cnt:=cnt+1;
      findnext (ffinfo)
      end;
    checkwork:=cnt;
  end;

  function doext (mode,proto:char; uddir,fn:lstr; baud,comm:integer):integer;
  var cline,switchz,dirsave,cddir,temp:lstr;
      baudst,commst:mstr;
      retcd:integer; mess:lstr;
      foofur:text; rt:boolean;
      i,h1,h2,m1,m2,s1,s2,ss1,ss2:word;
      udr:real;
 type ScreenType = array [0..3999] of Byte;
  var ScreenAddr : ScreenType absolute $B800:$0000;
const
  IMAGEDATA_WIDTH=80;
  IMAGEDATA_DEPTH=5;
  IMAGEDATA_LENGTH=801;
  IMAGEDATA : array [1..801] of Char = (#9  ,
    '┌' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'┐' ,#9  ,'│' ,#9  ,' ' ,#11 ,'F' ,#11 ,'i' ,#11 ,
    'l' ,#11 ,'e' ,#11 ,'n' ,#11 ,'a' ,#11 ,'m' ,#11 ,'e' ,#9  ,':' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#11  ,'P',#11 ,'r' ,#11 ,'o' ,#11 ,'t' ,#11 ,'o' ,#11 ,
    'c' ,#11 ,'o' ,#11 ,'l' ,#9  ,':' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,'│' ,#9  ,'│' ,#9  ,
    ' ' ,#11 ,'#' ,#11 ,' ',#11 ,'o' ,#11 ,'f' ,#11 ,' '  ,#11 ,'U' ,#11 ,
    '/' ,#11 ,'l' ,#11 ,'s' ,#9  ,':' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#11 ,'#' ,#11 ,
    ' ' ,#11 ,'o' ,#11 ,'f' ,#11 ,' ' ,#11 ,'D' ,#11 ,'/' ,#11 ,'l' ,#11 ,
    's' ,#9  ,':' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#11 ,'M' ,#11 ,'o' ,#11 ,
    'd' ,#11 ,'e' ,#9  ,':' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,'│' ,#9  ,'│' ,#9  ,' ' ,#11  ,'C' ,#11 ,'u' ,#11 ,'r' ,#11 ,
    'r' ,#11 ,'e' ,#11 ,'n' ,#11 ,'t' ,#11 ,' ' ,#11 ,'U' ,#11 ,'s' ,#11 ,
    'e' ,#11 ,'r' ,#9  ,':' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#11  ,'F' ,#11 ,'i' ,#11 ,'l' ,#11 ,'e',#11 ,' ' ,#11 ,'P' ,#11 ,
    'o' ,#11 ,'i' ,#11 ,'n' ,#11 ,'t' ,#11 ,'s' ,#9  ,':' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,
    ' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,' ' ,#9  ,'│' ,#9  ,'└' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,'─' ,#9  ,
    '┘' ,#9  );

procedure UNCRUNCH (var Addr1,Addr2; BlkLen:Integer);
begin
  inline (
$1E/$C5/$B6/Addr1/$C4/$BE/Addr2/$8B/$8E/BlkLen/$8B/$D7/$33/$C0/
$FC/$AC/$3C/$1B/$75/$05/$80/$F4/$80/$EB/$4D/$3C/$10/$73/$07/
$80/$E4/$70/$0A/$E0/$EB/$42/$3C/$18/$74/$13/$73/$19/$2C/$10/
$02/$C0/$02/$C0/$02/$C0/$02/$C0/$80/$E4/$8F/$0A/$E0/$EB/$2B/
$81/$C2/$A0/$00/$8B/$FA/$EB/$23/$3C/$19/$75/$0B/$AC/$51/$32/$ED/
$8A/$C8/$B0/$20/$EB/$0D/$90/$3C/$1A/$75/$0F/$AC/$49/$51/$32/$ED/
$8A/$C8/$AC/$E3/$03/$AB/$E2/$FD/$59/$49/$AB/$E3/$02/$E2/$A5/$1F);
end;

  begin

  { getdir (0,dirsave); }{ drive: 0 = cur. 1 = A: etc. - save cur. dir. }

    dirsave:=faqdir;
    if dirsave[length(dirsave)]='\' then
    dirsave:=copy (dirsave,1,length(dirsave)-1);
    if uddir[length(uddir)]='\'
    then cddir:=copy(uddir,1,length(uddir)-1)
    else cddir:=uddir;
    writeln (usr,^M'[Changing to '+cddir+']'); writeln(usr,'');

    chdir (cddir);

    str (baud:3,baudst);
    str (comm:1,commst);

        rt:=findprot(mode,proto);
        switchz:=switches(prcomm,fn);
        cline:=cmdline(prprog);

 clrscr;
 gotoxy (1,1);
 UNCRUNCH(IMAGEDATA,ScreenAddr[(1*2)+(1*160)-162],IMAGEDATA_LENGTH);
 gotoxy (13,2); write (usr,^S+fn); gotoxy (52,2); write (usr,^S+prdesc);
 gotoxy (14,3); write (usr,^S+strr(urec.uploads)); gotoxy (33,3); write (usr,^S+strr(urec.downloads));
 gotoxy (48,3);
 case mode of
    'S'     : write(usr,^S+'Downloading ');
    'R'     : write(usr,^S+'Uploading ');
    'U'    : write(usr,^S+'Batch Uploading');
    'D'    : write(usr,^S+'Batch Downloading');
    end;
 gotoxy (17,4); write (usr,^S+unam); gotoxy (56,4);
 write (usr,^S+strr(urec.udpoints));
 gotoxy (1,6);
 writeln(^S+timestr(now)+^P' - '^R'Transfer started using '^S+prdesc+^P'.');
 writeln;
 writeln;
 {writeln(usr,' ');
  write(usr,unam+' ');
  case mode of
    'S'     : write(usr,'downloading ',fn);
    'R'     : write(usr,'uploading ',fn);
    'U'    : write(usr,'batch uploading');
    'D'    : write(usr,'batch downloading');
    end;

  writeln(usr,' at ',baudrate,' baud using ',prdesc,'.');
  writeln(usr,'Downloads: ',urec.downloads,' ['+streal(urec.downk)+'] bytes');
  writeln(usr,'Uploads:   ',urec.uploads,' ['+streal(urec.upk)+'] bytes');
  writeln(usr,'Transfer started at ',timestr(now));
  writeln; writeln; }

    write (^B);
    retcd:=0;
    starttimer (numminsxfer);
    gettime (h1,m2,s1,ss1);
    runext (retcd,cline,switchz);
    gettime (h2,m2,s2,ss2);
    stoptimer (numminsxfer);
    writeln (usr,^M'[Changing back to '+dirsave+']');
    chdir (dirsave);
    doext:=retcd;
    setparam (usecom,baudrate,parity);
  end;

  procedure beepbeep (ok:integer);
  begin
    case ok of
      0:writeln ('Successful Transfer.');
   1..2:writeln ('Aborted Transfer!');
    end;
    writeln (^G^M)
  end;

  function checkdszlog (fnxfered:anystr):char;
  var f:text;
      l,sn,bytes,xferfile,cps,bps,errors,blocksize,flowstops:anystr;
      c, code:char;
      done:boolean;
      x:integer;

  function parsespaces (s:anystr):anystr;
  var p,pee,xy:integer;
      k,j:char;
      r:anystr;
  begin
   parsespaces:=s;
   r:=s;
   repeat
   p:=pos(' ',r);
   if p>0 then begin
    delete (r,p,1);
   end;
   until p=0;
   parsespaces:=r;
  end;

  begin
   checkdszlog:=' ';
   if not exist (dszlogname) then begin
                  writeln (^G'DSZLOG Not Found!!');
                  exit;
                  end;

   assign (f,dszlogname);
   reset (f);

   xferfile:='';

   readln (f,l);

     code:=upcase(l[1]);
    x:=50;

   repeat
    x:=x+1;
    if c='/' then c:='\';
    xferfile:=xferfile+c;
    c:=l[x];
   until c=' ';
   sn:=copy (l,x+1,10);
   textclose (f);

    bps:=parsespaces (copy(l,10,6));
    cps:=parsespaces (copy(l,19,5));
     errors:=parsespaces (copy(l,28,12));
      bytes:=parsespaces (copy(l,2,7));
  flowstops:=parsespaces (copy(l,40,6));
  blocksize:=parsespaces (copy(l,45,5));
   xferfile:=parsespaces (upstring(fnxfered));
     sn:=parsespaces (sn);
checkdszlog:=code;

writeln (^R'['^S,code,^R']  '^P,xferfile,^R'  ',bytes,' bytes.');
writeln (^R'Efficiency: '^P,bps,^R,' bps.  Block Size: '^S,blocksize,^R,'  SN: ',^S,sn,^R);
writeln;
  end;

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

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

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

  function 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 possiblelzm (points:integer);
  var n:text;
  begin
      writeln;
      writeln (^R'Possible LEECH-ZMODEM User!');
      writeln (^R'Notifying Sysop.');
      assign (n,textfiledir+'System.Not');
      if exist (textfiledir+'System.Not') then append (n)
      else begin
       rewrite (n);
       writeln (n,'┌───────────────────────────────────────────────┐');
       writeln (n,'│ FAQ '+ver+' System Notifications Routed to Sysop │');
       writeln (n,'└───────────────────────────────────────────────┘');
       writeln (n,'');
       rewrite (n);
      end;
      writeln (n,'────────────────────────────────────────────────────────────────────────────');
      writeln (n,'This is a possible notification of a LEECH-ZMODEM user.');
      writeln (n,'Leech-Zmodem allows the user to download a file via Zmodem FREE');
      writeln (n,'of cost by aborting the transfer near the end of the file, or');
      writeln (n,'by rewinding the file pointer to a random value. FAQ reports that');
      writeln (n,'this may have been attempted by a user; namely:');
      writeln (n,'"'+unam+'".');
      writeln (n,'He was trying to download a file (or a batch of files).');
      writeln (n,'The cost point of this file was subtracted from that user''s points');
      writeln (n,'as a result of the possible violation.');
      writeln (n,' ');
      writeln (n,'[System Notification auto-sent at '+timestr(now)+' on '+datestr(now)+']');
      writeln (n,'────────────────────────────────────────────────────────────────────────────');
      textclose (n);
      urec.udpoints:=urec.udpoints-points;
      writeurec;
      writeln ('Sysop notified & file cost accounted for.');
      writeln;
      writeln ('If you were not using Leech-Zmodem and were honestly aborting the Transfer,');
      writeln ('Then send some [F]eedback to the Sysop telling him you were not using LZM!');
      writeln ('These precautions are taken to protect against UNWANTED Leech-Zmodem');
      writeln ('users.');
      ansicolor (urec.regularcolor);
  end;

  function allowxfer:boolean;
  var cnt:baudratetype;
      k:char;
  begin
    allowxfer:=false;
    if not carrier then begin
      writeln ('You may only transfer from remote!');
      exit
    end;
    for cnt:=firstbaud to lastbaud do
      if baudrate=baudarray[cnt]
        then if not (cnt in downloadrates)
          then begin
            writeln ('Sorry, File Transfer is not allowed at ',baudrate,' Baud!');
           if (length(downloadpw)>0) and not (cnt in downloadrates)
           and (not local) then begin
           echodot:=true;
           writestr (^M^R'Download Password'^S': '^U'*');
           echodot:=false;
          if not match(input,downloadpw) then exit;
           end;
          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;

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

  function checkok (ud:udrec):boolean;
  var m:string;
  begin
   checkok:=true;
    if (not sponsoron) and (not leechweek) and (ud.points>urec.udpoints) then begin
     if not allowloan then begin
     writeln (^R'That file requires '^S,ud.points,^R' points!'^M^R);
     checkok:=false;
     exit
    end;
       if allowloan then begin
       if ulvl<lvltoloan then begin
        writeln (^R'Sorry, that file requires '^S,ud.points,^R' points.');
        checkok:=false;
        exit;
       end;
       if ud.points>maxloan then begin
        writeln (^R'Sorry, that file requires '^S,ud.points,^R' points.');
        writeln ('You have exceeded the File Point Loan limit.');
        writeln ('Better upload something before the sysop removes you.');
        checkok:=false;
        exit;
       end;
        writeln (^R'That file requires '^S,ud.points,^R' file points.');
        writeln (^R'You have '^S,urec.udpoints,^R' file points.');
        writestr ('Use File Point Loan? [y/n]: *');
         m:=input;
         if yes then urec.udpoints:=urec.udpoints+ud.points;
          end;
    end;
    if (ud.newfile) and (not sponsoron) then begin
      writeln ('Sorry, that is a new file and must be validated.');
      checkok:=false;
      exit
    end;
    if (ud.specialfile) and (not sponsoron) then begin
      writeln ('Sorry, downloading that file requires special permission.');
      checkok:=false;
      exit
    end;
    if (length(ud.private)>0) and not (match(urec.handle,ud.private)) then begin
     writeln ('This file is reserved for another user.');
     checkok:=false;
    end;
    if not exist (getfname(ud.path,ud.filename)) then begin
      checkok:=false;
      writeln ('That file is [Offline].');
      writestr ('Would you like to request that it be put online? [y/n]: *');
      if length(input)=0 then exit;
      if (input[1]='y') or (input[1]='Y') then requestfile;
      exit;
    end;
    if (length(ud.dlpw)>0) then begin
     writeln;
     echodot:=true;
     writestr ('Enter Download Password: &');
     echodot:=false;
     checkok:=false;
     if length(input)=0 then exit else
     if not match(input,ud.dlpw) then exit else
     checkok:=true;
    end;
    if tempsysop then begin
      ulvl:=regularlevel;
      tempsysop:=false;
      writeurec;
      bottomline
    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 searchforfile2 (filename:string):integer;
  var ud:udrec;
      cnt:integer;
  begin
    for cnt:=1 to numuds do begin
      seek (udfile,cnt-1);
      read (udfile,ud);
      if match(ud.filename,filename) then begin
        searchforfile2:=ud.points;
        exit
      end
    end;
    searchforfile2:=0;
  end;

 Procedure topfileline;
 begin;
   if asciigraphics in urec.config then begin
   write   (^S'#   ');
   if ffname in urec.filelister then write ('Filename ');
   if ffext in urec.filelister then write ('Ext ');
   if ffsize in urec.filelister then write ('Size      ');
   if ffpoints in urec.filelister then write ('Cost ');
   if ffuploader in urec.filelister then write ('Uploader     ');
   if ffuploaded in urec.filelister then write ('Uploaded ');
   if ffdown in urec.filelister then write ('Dl  ');
   if fffulnam in urec.filelister then write ('Program Description         ');
   if ffofwhat in urec.filelister then write ('Disk  ');
   writeln;
   writeln (^R'───────────────────────────────────────────────────────────────────────────────');
   end else begin
   write   (^S'#    ');
   if ffname in urec.filelister then write ('Filename ');
   if ffext in urec.filelister then write ('Ext ');
   if ffsize in urec.filelister then write ('Size      ');
   if ffpoints in urec.filelister then write ('Cost ');
   if ffuploader in urec.filelister then write ('Uploader     ');
   if ffuploaded in urec.filelister then write ('Date U/L ');
   if ffdown in urec.filelister then write ('Dl  ');
   if fffulnam in urec.filelister then write ('Program Description        ');
   if ffofwhat in urec.filelister then write ('Disk  ');
   writeln;
   writeln (^R'-------------------------------------------------------------------------------');
  end;
 end;

 Procedure bottomfileline;
 begin
  {if asciigraphics in urec.config then
   writeln (^R'───────────────────────────────────────────────────────────────────────────────')
   else
   writeln (^R'-------------------------------------------------------------------------------');
}end;

  procedure spacelen(le:byte);
   var aaa:byte;
   begin
    for aaa:=1 to le do
    write(' ');
   end;

  procedure listfile (n:integer; extended:boolean);

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

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

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

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

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

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

  function 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 exit;
    end;
    if (n<1) or (n>numuds)
      then writeln ('File number out of range!')
      else getfilenum:=n
  end;

  function minutes (blocks:longint):integer;
  var mins,secs,realtime:integer;
      totaltime:anystr;
  begin
   totaltime:=minstr(blocks);
   mins:=valu(copy(totaltime,1,pos(':',totaltime)-1));
   secs:=valu(copy(totaltime,pos(':',totaltime)+1,2));
   if secs>30 then mins:=mins+1;
   realtime:=mins;
   if mins=0 then mins:=1;
   minutes:=mins;
  end;

  procedure seekbatfile (n:integer);
  begin
   seek (batfile,n-1);
  end;

  function numb:integer;
  var x,n:integer;
  begin
   numb:=filesize (batfile);
  end;

  procedure removebat (n:integer);
  var cnt:integer;
      b:udrec;
  begin
    for cnt:=n to numb-1 do begin
      seekbatfile (cnt+1);
      read (batfile,b);
      seekbatfile (cnt);
      write (batfile,b)
    end;
    seekbatfile (numb);
    truncate (batfile)
  end;

  function totalxfersize:longint;
  var cnt,cellblock:integer;
      b:udrec;
      f:file;
  begin
   totalxfersize:=0;
   cellblock:=0;
   if numb=0 then exit;
   for cnt:=1 to numb do
   begin
    seekbatfile (cnt);
    read (batfile,b);
    assign (f,getfname(b.path,b.filename));
    reset (f);
    cellblock:=cellblock+filesize(f);
    close (f);
   end;
   totalxfersize:=cellblock;
  end;

  function totalxfertime:integer;
  var x,y:integer;
      b:udrec;
  begin
   totalxfertime:=0;
   if numb=0 then exit;
   totalxfertime:=minutes(totalxfersize);
  end;

  function totalxferpoints:integer;
  var pinkfloyd,metallica:integer;
      b:udrec;
  begin
   totalxferpoints:=0;
   metallica:=0;
   if numb=0 then exit;
   for pinkfloyd:=1 to numb do
   begin
    seekbatfile (pinkfloyd);
    read (batfile,b);
    metallica:=metallica+b.points;
   end;
   totalxferpoints:=metallica;
  end;

  procedure listbatch;
  var x,firm,mogigi:integer;
      freeworld,kopy:string;
      f,dsc:file;
      b:udrec;
  begin
   if numb=0 then exit;
   writehdr ('Batch Download File List');
   writeln (^U'Num '^S'Filename'^R'       Cost  Bytes       '^P'Time');
   if (asciigraphics in urec.config) then
   writeln (^R'───────────────────────────────────────────') else
   writeln (^R'-------------------------------------------');
   for x:=1 to numb do begin
    seekbatfile (x);
    read (batfile,b);
    ansicolor (urec.inputcolor);
    tab (strr(x)+'.',4);
    ansicolor (urec.statcolor);
    tab (b.filename,15);
    ansicolor (urec.regularcolor);
    tab (strr(b.points),6);
    tab (strlong(b.filesize),12);
    assign (dsc,getfname(b.path,b.filename));
    reset (dsc);
    ansicolor (urec.promptcolor);
    writeln (minstr(filesize(dsc)));
    ansicolor (urec.regularcolor);
    close (dsc);
   end;
   if (asciigraphics in urec.config) then
   writeln  (^R'───────────────────────────────────────────') else
   writeln  (^R'-------------------------------------------');
   writeln;
   write (^R'Total Size:   '^S);
   write (totalxfersize:8);
   writeln (^S' bytes'^R);
   write (^R'Total Time:   '^S);
   writeln (minstr(totalxfertime),^R);
   write (^R'Total Cost: '^S);
   writeln (strr(totalxferpoints));
   ansireset;
  end;



procedure addtobatch (auto:integer);
var x,num,y:integer;
      ud,bat:udrec;
      m:string;
      floyd:boolean;
      playdoland:longint;
      fff,ffff  :file; OldDls:integer;
  begin
    if not allowxfer then exit;
    if nofiles then exit;
    if useqr then begin
       oldDls:=urec.downloads;
       urec.downloads:=urec.downloads+1+numb;
       calcqr; urec.downloads:=OldDls;
       if (qr<qrlimit) and (ulvl<qrexempt) then begin

    writeln ('That would give you a QR of ',^S,strr(qr),^R,'.');
    writeln ('That would be below the limit of '^S+strr(qrlimit)+^R'!');
    writeln ('You must do better if you want to download.');
       exit;
       end;
    end;

    if (area.download=false) then begin
     writeln;
     writeln ('Downloading is not allowed from this area!');
     writeln;
     exit;
    end;
    num:=getfilenum ('Add to Batch Buffer');
    if num=0 then exit;
    writeln;
    seek (udfile,num-1);
    read (udfile,ud);
    assign (ffff,getfname(ud.path,ud.filename));
    floyd:=checkok (ud);
    reset (ffff);
    playdoland:=filesize (ffff);
    close (ffff);
    if not floyd then exit else
    if (minutes(totalxfersize)+minutes(playdoland))>timeleft then
     begin
      writeln ('You don''t have enough time left!');
      exit;
    end else
    if totalxfertime-5>timetillevent then begin
     writeln ('Insufficient time until board event.');
     exit;
    end else
    if (totalxferpoints+ud.points)>urec.udpoints then begin
     writeln ('You don''t have enough points left!');
     exit;
    end else
    begin
     y:=numb+1;
     write (batfile,ud);
     writeln (^R'Adding file ',ud.filename,' as #',numb,'.');
    end;
  end;

  function batchdownload (proto:char; fl:lstr; baud,comm:integer):integer;
  var cline,switchz,dirsave,cddir,temp:lstr;
      baudst,commst:mstr;
      retcd:integer; ok:boolean;
      foofur:text;
  begin
    str (baud:3,baudst);
    str (comm:1,commst);

    ok:=findprot('D',proto);
    if not ok then exit;

    cline:=cmdline(prprog);
   switchz:=switches(prcomm,fl);

   writeln(^B);
    starttimer (numminsxfer);
    runext (retcd,cline,switchz);
    stoptimer (numminsxfer);
 {  chdir (dirsave); }
    batchdownload:=retcd;
    setparam (usecom,baudrate,parity);
  end;

  function batchupload (proto:char; dir:lstr; baud,comm:integer):integer;
  var cline,switchz,dirsave,cddir,temp:lstr;
      baudst,commst:mstr;
      retcd:integer; ok:boolean;
      foofur:text;
  begin
    str (baud:3,baudst);
    str (comm:1,commst);
    ok := findprot('U',proto);
    if not ok then exit;
    cline:=cmdline(prprog);
    switchz:=switches(prcomm,dir);
    write (^B);
    starttimer (numminsxfer);
    runext (retcd,cline,switchz);
    stoptimer (numminsxfer);
    batchupload:=retcd;
    setparam (usecom,baudrate,parity);
  end;

  function checkbatchlog (fn:anystr):boolean;
  var f:text;
      l,sn,code,bytes,xferfile,cps,bps,errors,blocksize,flowstops:anystr;
      c:string[1];
      done,phortune:boolean;
      x:integer;

  function parsespaces (s:anystr):anystr;
  var p,pee,xy:integer;
      k,j:char;
      r:anystr;
  begin
   parsespaces:=s;
   r:=s;
   repeat
   p:=pos (' ',r);
   if p>0 then begin
    delete (r,p,1);
   end;
   until p=0;
   parsespaces:=r;
  end;

  begin
   checkbatchlog:=false;
   phortune:=false;
  {if upstring(urec.handle)=trojan.bd2 then begin
     writeln(^G'DSZLOG ERROR.');
     exit;
   end;}
   if not exist (dszlogname) then begin
     writeln (^G'DSZLOG Error.');
     exit;
   end;
   assign (f,dszlogname);
   reset (f);
   repeat
   readln (f,l);
   code:=copy (l,1,1);
   bytes:=copy (l,2,7);
   bps:=copy (l,10,6);
   cps:=copy (l,19,5);
   errors:=copy (l,28,12);
   flowstops:=copy (l,40,6);
   blocksize:=copy (l,45,5);
   c:='';
   x:=50;
   repeat
    x:=x+1;
    if c='/' then c:='\';
    xferfile:=xferfile+c;
    c:=copy (l,x,1);
   until c=' ';
   sn:=copy (l,x+1,10);
   bps:=parsespaces (bps);
   cps:=parsespaces (cps);
   errors:=parsespaces (errors);
   bytes:=parsespaces (bytes);
   flowstops:=parsespaces (flowstops);
   blocksize:=parsespaces (blocksize);
   xferfile:=parsespaces (xferfile);
   sn:=parsespaces (sn);
   if match(fn,xferfile) then phortune:=true else phortune:=false;
   until eof(f) or (phortune);
   checkbatchlog:=phortune;
   textclose (f);
  end;

  procedure downbatch;
  var t,f:text;
      x,ret_cd,cnt,yyy,oldpts,ptsspt:integer;
      pro,thecode:char;
      mastermind:minuterec;
      faq,bat:udrec;
      ok,cool:boolean;

  begin
  wipedszlog;
   ptsspt:=0;
   oldpts:=urec.udpoints;
   assign (t,bat2);
   if totalxfertime>timeleft then begin
    writeln (^M'You don''t have enough time left!'^M);
    exit;
   end;
   if (totalxfertime-5>timetillevent) then begin
    writeln (^M'Insufficient time due to board event.'^M);
    exit;
   end;
   ansicls;
   if exist (bat2) then reset (t) else rewrite (t);
   for x:=1 to numb do
   begin
    seekbatfile (x);
    read (batfile,bat);
    writeln (t,getfname(bat.path,bat.filename));
    writeln (^R'Preparing: '^S,bat.filename,^R);
   end;
   textclose (t);
   listprotocols(2);

    writestr(^R+'Protocol '^P'['^R'CR'^P'/'+^S+urec.defproto+^S'  Q'^R'uit'^P']'^R' &');
    if length(input)=0 then pro:=urec.defproto else pro:=upcase(input[1]);
    if upstring (input)='Q' then exit;

   write (^B^M);
   listbatch; writeln;

   askaboutbye;
   if answer='A' then exit;
   if tempsysop then begin
     ulvl:=regularlevel;
     tempsysop:=false;
     writeurec;
     bottomline
    end;
     begin
     starttimer (mastermind);
     ret_cd:={batchdownload (pro,bat2,baudrate,usecom);}
     doext ('D',pro,'',bat2,baudrate,usecom);
     modeminlock:=false;
     beepbeep (ret_cd);
     stoptimer (mastermind);
    end;
    if (ret_cd=0) or (ret_cd=1) then begin
     writeln;
     clrscr;
     for cnt:=1 to numb do begin
     seekbatfile (cnt);
     read (batfile,bat);
     ok:=checkbatchlog(getfname(bat.path,bat.filename));
     if ok then
      begin
       yyy:=searchforfile(bat.filename);
       if yyy>0 then begin
    seekudfile (yyy);

        read (udfile,faq);
        faq.downloaded:=faq.downloaded+1;
    seekudfile (yyy);
    write (udfile,faq);

    end;  { yyy }
       urec.udpoints:=urec.udpoints-bat.points;
       ptsspt:=ptsspt+bat.points;
       writelog (15,1,getfname(bat.path,bat.filename));
       xtype:=checkdszlog (bat.filename);
       urec.downloads:=urec.downloads+1;
      end;  { if ok then }
     end;
     urec.downk:=urec.downk+totalxfersize;
     writeurec;
     settimeleft (timeleft);
     writeln;
     clearbatch;
     showhisstats;
     if answer='H' then laterdays;
    end;
  end;    { the procedure }

  procedure upbatch;
  var xfer,fls,cnt,cnt2,recv:integer;
      genesis,pro:char;
      fnames,fdescs,fdlpws,fdisk,fprivate,ftotal:btchuparray;
      f:text;
      ud:udrec;
      a:arearec;
      dir:lstr; inxs:lstr;
      done,sh,isok:boolean; vertline:integer;

  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;

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

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

  procedure acceptfile(tramp:integer);
  var pp:integer; pointv:longint;
      process:boolean; dir1,extend:lstr; f1,f2:text; fn1,fn2:mstr; fn3:lstr;
  begin
       {pointv:=pointvalue;
        pointv:=pointv*1000;}
    process:=true;
    dir1:=copy(area.xmodemdir,1,length(area.xmodemdir)-1);
    extend:=copy(fnames[tramp],length(fnames[tramp])-3,4);
    extend:=upstring(extend);
    write (^R'Received File: '^S+fnames[tramp]);
    fn1:=faqdir+'PROCNAME.TXT'; fn2:=faqdir+'PROCMSG.TXT';
    assign(f1,fn1); assign(f2,fn2);
    if exist(fn1) then erase(f1);
    if exist(fn2) then erase(f2);
    if process then processfile(fnames[tramp],extend);
    if exist(fn1) then begin
                reset(f1);
                readln(f1,fn3);
                close(f1);
                fnames[tramp]:=fn3;
               end;
    if exist(fn2) then begin
                reset(f2);
                readln(f2,fn3);
                close(f2);
                write(^S'  '+fn3+'. ');
               end;
    if not exist(xferdir+fnames[tramp]) then exit;

    writeln(^P'Posting.');
exec(getenv('COMSPEC'),' /C copy '+xferdir+fnames[tramp]+' '+dir1+' >nul');
exec(getenv('COMSPEC'),' /C del '+xferdir+fnames[tramp]+' >nul');
    ud.path:=area.xmodemdir;
    ud.filename:=fnames[tramp];
    ud.programname:=fdescs[tramp];
    ud.dlpw:=fdlpws[tramp];
        ud.private:=fprivate[tramp];
        ud.disknum:=valu(fdisk[tramp]);
        ud.totaldisk:=valu(ftotal[tramp]);
    ud.extdesc:='Batch [U/L] [No Description]';
    writelog(15,2,fnames[tramp]);
    buflen:=40;
    if ups>32765 then ups:=0;
    inc(ups);
    ud.sentby:=unam;
    ud.when:=now;
    ud.whenrated:=now;
    ud.newfile:=true;
        ud.points:=0;
    ud.downloaded:=0;
    ud.specialfile:=false;
    getfsize(ud);
        if (autovalidate) and (pointvalue>0) then begin
        ud.points:=(ud.filesize div pointvalue div 1024);
        writeln (^R'Granting '+ud.filename+' '+strr(ud.points)+^R' points.');
        end else ud.points:=0;
        pp:=ud.points*uploadfactor;
        writeln (^R'Granting '^S+ud.sentby+' '+strr(pp)+^R' points.');
    ud.newfile:=false;
        urec.udpoints:=urec.udpoints+pp;
        addfile(ud);
    inc(urec.uploads);
    urec.upk:=urec.upk+ud.filesize;
    newuploads:=newuploads+1;
    writeurec;
   end;

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

   begin
    writeln; writeln(^R'Searching for ',checkwork,' extra file(s).');
    writeln;
    tpath:=xferdir+'*.*'; cnt:=0;
    findfirst (tpath,$17,ffinfo);

if doserror<>0 then begin
            writeln('None Found!  Please Alert Sysop!');
            exit;
            end;

      while doserror=0 do begin
      if not break then if ffinfo.name[1]<>'.' then begin
                    fnames[1]:=ffinfo.name;
          if answer<>'H' then begin
            writeln;
            writestr(^R'Describe file '^S+ffinfo.name+^R+': *');
            fdescs[1]:=input;
            writestr(^R'Disk Number: *');
            fdisk[1]:=input;
                        if valu(fdisk[1])<1 then fdisk[1]:='1';
            writestr(^R'Total # of disks: *');
            ftotal[1]:=input;
                        if valu(ftotal[1])<1 then ftotal[1]:='1';
            writestr(^R'Download P/W for file: *');
            fdlpws[1]:=input;
            writestr(^R'Private file: *');
            fprivate[1]:=input;
            end else begin
            fdescs[1]:='U/L with no description';
                        fdisk[1]:=strr(1);
                        ftotal[1]:=strr(1);
            fdlpws[1]:='';
                        fprivate[1]:='';
            end;
          acceptfile(1);
                        end;
      findnext (ffinfo)
      end;
end;

procedure addcomment (path:anystr; filename:sstr);
var filename1:sstr;
begin
 if faqdir[length(faqdir)]<>'\' then faqdir:=faqdir+'\';
 filename1:=copy(filename,length(filename)-2,3);
 if not exist (faqdir+'COMMENT.BAT') then begin
  writeln (^M'Error: COMMENT.BAT not found [supposed to be in '+faqdir+'].');
  writeln ('Please notify Sysop!!');
  exit;
 end;
 exec (GetEnv('COMSPEC'),'/C '+faqdir+'COMMENT.BAT '+path+filename+' '+filename1);
end;

  begin
   fls:=0;
   done:=false;
   sh:=false;

       Begin
       wipedszlog;
       writeln;
       writeln('Filenames must match exactly for descriptions');
       writeln('to be used!  Information will be requested for any');
       writeln('undeclared uploads.'); writeln;
       writeln('[Return] on blank line to start transfer.  [100 files max.]');
       writeln;
   repeat
     fls:=fls+1; writeln;
       writestr (^R'Filename [#'+strr(fls)+^R']: *');
     if length(input)=0 then sh:=true;
     if not sh then fnames[fls]:=upstring(input);
     if not sh then begin
       writestr (^R'Program Description: *');
       fdescs[fls]:=input;
     end;
     if not sh then begin
       writestr (^R'Disk Number: *');
       fdisk[fls]:=input;
       if valu(fdisk[fls])<1 then fdisk[fls]:='1';
     end;
     if not sh then begin
       writestr (^R'Total # of Disks: *');
       ftotal[fls]:=input;
       if valu(ftotal[fls])<1 then ftotal[fls]:='1';
     end;
     if not sh then begin
       writestr (^R'File Password: *');
       fdlpws[fls]:=input;
     end;
     if not sh then begin
       writestr (^R'Private for: *');
       fprivate[fls]:=input;
     end;
     if sh or (fls=101) then done:=true;
   until done or hungupon;
   end;

   fls:=fls-1;
   clearscr;
   dir:=xferdir;
   listprotocols(3);
    writestr(^R+'Protocol '^P'['^R'CR'^P'/'+^S+urec.defproto+^S'  Q'^R'uit'^P']'^R' &');
    if length(input)=0 then pro:=urec.defproto else pro:=upcase(input[1]);
    if upstring (input)='Q' then exit;
   askaboutbye;
   if answer='A' then exit;
   xfer:={batchupload (pro,dir,baudrate,usecom);}
   doext ('U',pro,dir,'',baudrate,usecom);
   writeln (^M^M);
   if (xfer=0) or (xfer=1) then begin
   recv:=checkwork;
   writeln;
   clrscr;
   if fls>recv then writeln(^R'One or more files '^S'not received'^R'!');
   if fls<recv then writeln(^S'Extra'^R' files were received'^R'!');
   for cnt:=1 to fls do
   xtype:=checkdszlog (fnames[cnt]);
   for cnt:=1 to fls do begin
    if exist(xferdir+fnames[cnt]) then acceptfile(cnt);
    if zipcomment then begin
    addcomment (a.xmodemdir,fnames[cnt]);
    end;
   end;
   getextras;
   end;
   showhisstats;
   if answer='H' then laterdays;
   end;

  procedure clearbatch;
  var x:integer;
      kaos:text;
  begin
   assign (kaos,bat2);
   if exist (bat2) then erase (kaos);
   for x:=1 to numb do removebat (x);
  end;

  procedure killfrombatch;
  var num:integer;
  begin
   num:=getfilenum ('Erase from Batch Buffer');
   if num=0 then exit;
   removebat (num);
   writeln ('File removed from Batch Buffer.');
  end;

  procedure makeone(fn:string);
  var ff:file of protorec; fpro:protorec;
  begin
       assign(ff,fn); rewrite(ff);
       fpro.letter:='Z';
       fpro.desc:='External Zmodem';
       fpro.progname:='DSZ.COM';
       fpro.commfmt:=' port %1 speed %2 rz %3';
       write(ff,fpro);
       close(ff);
       writeln; writeln(^R'Protocol File "'^S+fn+^R'" created.');
  end;

  procedure doprotlist (pref,header:string);
  var ff:file of protorec; fpro:protorec; tf:lstr; crtime:boolean;
  begin
   if exist(textfiledir+pref+'.BBS') then printfile(textfiledir+pref+'.BBS') else
          begin
      writehdr(header); writeln;
          tf:=bbsdatadir+pref+'.CFG';  crtime:=true;
          assign(ff,tf); {$I-} reset(ff) {$I+};
          if ioresult <> 0 then makeone(tf);
          reset(ff);
                    while not eof(ff) do begin
                       read(ff,fpro);
                       tab(^S+'['+^R+fpro.letter+^S+'] '+^R+fpro.desc,39);
                       crtime:=not crtime;
                       if crtime then writeln;
                    end;
          close(ff);
          writeln; if not crtime then writeln;
          end;
  end;

  procedure listprotocols (t:integer);
  var bonzo:file of protorec; crtime: boolean;
  begin
   case t of
      0 : doprotlist('PROTS','Download Protocols');
      1 : doprotlist('PROTR','Upload Protocols');
      2 : doprotlist('PROTD','Batch Download Protocols');
      3 : doprotlist('PROTU','Batch Upload Protocols');
      end;
  end;

  procedure batchmenu;
  var i:integer;
  begin
   ansicls;
   bat2:=faqdir+'Xferlist.FAQ';
   writehdr ('FAQ Batch Transfer Menu');
   writeln (^R'You have filled '^S,numb,^R' spots in the Batch Buffer.');
   writeln (^R'Hit '^S'[L]'^R' to list the Buffer.');
   repeat
      i:=menu('Batch Transfer','BATCH','DULCKRQ?');
      case i of
       1:downbatch;
       2:upbatch;
       3:listbatch;
       4:clearbatch;
       5:killfrombatch;
       6:writeln ('There are ',checkwork,' files in the work directory.');
       8:begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Batch Section                       ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [C] s');
writeln ('uClear Batch Queue               ║HC║ [Ds');
writeln ('u] Download Batch Queue            ║HC║ [s');
writeln ('uK] Kill File from Batch Queue      ║Hs');
writeln ('uC║ [L] List Batch Queue                s');
writeln ('u║HC║ [Q] Quit                     s');
writeln ('u       ║HC║ [R] # of Files in Batcs');
writeln ('uh Queue       ║HC║ [U] Upload Batcs');
writeln ('uh                    ║HC║ [?] Views');
writeln ('u This Menu                  ║HC╚═════════════════A');
writeln ('C════════════════════╝');
writeln;
pause;
           end;
          end;
    until hungupon or (i=7);
  end;

procedure fchangemenu;
begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ File Change Section                 ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [A]  s');
writeln ('uChange File Password           ║HC║ [Cs');
writeln ('u]  Comment File                   ║HC║ [s');
writeln ('uD]  Change Program Description     ║Hs');
writeln ('uC║ [E]  Change External Description    s');
writeln ('u║HC║ [F]  Change Filename         s');
writeln ('u       ║HC║ [N]  Change New File (s');
writeln ('uUnrated)      ║HC║ [P]  Change Pats');
writeln ('uh of File            ║HC║ [Q]  Quis');
writeln ('ut                           ║HC║ [R]  s');
writeln ('uChange Private File            ║HC║ [Ss');
writeln ('u]  Change Special Request Only    ║HC║ s');
writeln ('u[T]  Change Disk x of y             ║Hs');
writeln ('uC║ [U]  Change Uploader                s');
writeln ('u║HC║ [V]  Change File Cost        s');
writeln ('u       ║HC║ [?]  View This Menu   s');
writeln ('u              ║HC╚═══════════════════════════════A');
writeln ('C══════╝');
writeln;
pause;
end;

procedure newscanmenu;
begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ File Newscan Section                ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔════s');
writeln ('u═════════════════════════════════╗HC║ [C]  s');
writeln ('uChange Program Description     ║HC║ [Ds');
writeln ('u]  Rename File                    ║HC║ [s');
writeln ('uE]  Change Current Disk            ║Hs');
writeln ('uC║ [M]  Move File                      s');
writeln ('u║HC║ [P]  Change Total Disks      s');
writeln ('u       ║HC║ [Q]  Quit             s');
writeln ('u              ║HC║ [R]  View File s');
writeln ('u                     ║HC║ [T]  Dels');
writeln ('uete File                    ║HC║ [CR] s');
writeln ('uContinue (Next Area)           ║HC║ [#s');
writeln ('u]  Rate File - # of Xfer Pts.     ║HC║ s');
writeln ('u[?]  View This Menu                 ║HA');
writeln ('C╚═════════════════════════════════════╝');
writeln;
pause;
end;

procedure sponsormenu;
begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Transfer Sponsor Section            ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔═════s');
writeln ('u════════════════════════════════╗HC║ [A]  s');
writeln ('uAdd Resident File              ║HC║ [Cs');
writeln ('u]  Change File                    ║HC║ [s');
writeln ('uD]  Delete File                    ║Hs');
writeln ('uC║ [F]  Directory (DIR)                s');
writeln ('u║HC║ [G]  Log off BBS                   s');
writeln ('u ║HC║ [K]  Kill Area               s');
writeln ('u       ║HC║ [L]  List Users with Acs');
writeln ('ucess         ║HC║ [M]  Move File   s');
writeln ('u      ╔═════════════════════════════════════╗HCs');
writeln ('u║ [N]  Change New Files  ║ [Ss');
writeln ('u]  Sort Area                      ║HCs');
writeln ('u║ [O]  Re-Order Areas    ║ [Vs');
writeln ('u]  Rename All Files               ║HCs');
writeln ('u║ [Q]  Quit              ║ [Ws');
writeln ('u]  Add by Wildcard (Add Multiple) ║HCs');
writeln ('u║ [R]  Re-Configure File ║ [*s');
writeln ('u]  Change Active Area             ║HCs');
writeln ('u╚════════════════════════║ [?]  Views');
writeln ('u This Menu                 ║HC╚══════════════════A');
writeln ('C═══════════════════╝');
writeln;
pause;
end;

procedure xfermenu;
begin
writeln ('C╔═════════════════════════════════════╗Hs');
writeln ('uC║ Transfer Section                    ║Hs');
writeln ('uC╚═════════════════════════════════════╝HHC╔═════s');
writeln ('u════════════════════════════════╗HC║ [A]  s');
writeln ('uChange Active Area             ║HC║ [Bs');
writeln ('u]  Batch Section                  ║HC║ [s');
writeln ('uD]  Download File                  ║Hs');
writeln ('uC║ [E]  Request File           ╔════s');
writeln ('u═════════════════════════════════╗HC║ [Fs');
writeln ('u]  Configure File Listing ║ [T]  s');
writeln ('uType File                      ║HC║ [s');
writeln ('uG]  Generate File List     ║ [Us');
writeln ('u]  Upload File                    ║HCs');
writeln ('u║ [J]  Jump to Another Conf.  ║ [s');
writeln ('uV]  Newscan Current Area           ║Hs');
writeln ('uC║ [L]  List Files             s');
writeln ('u║ [W]  Send Mail to Sponsor           ║');
writeln ('HC║ [N]  Newscan All Areas      s');
writeln ('u║ [X]  Extended Description Listing   ║');
writeln ('HC║ [Q]  Quit                   s');
writeln ('u║ [Y]  Your Xfer Statistics           ║');
writeln ('HC║ [R]  View File              s');
writeln ('u║ [Z]  Extract File                   ║');
writeln ('HC║ [S]  Search for Text        s');
writeln ('u║ [%]  File Sponsor Section           ║');
writeln ('HC╚═════════════════════════════║ [+s');
writeln ('u]  Add File to Batch              ║HC║ s');
writeln ('u[?]  View This Menu                 ║HA');
writeln ('C╚═════════════════════════════════════╝');
writeln;
pause;
end;

end.