Jason Aller Floppy Collection/341.img/TCS161S.ZIP/PROTOCOL.PAS

Pascal/Delphi Source File | 1989-12-26 | 35KB | 1,301 lines

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

unit protocol;

interface

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

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

var totaltime      :sstr;
    b              :string;
    mins           :integer;
    status         :word;
    curarea        :integer;
    totpoints      :word;
    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;

implementation



  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:=forumdir+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;
                    end;
               delete (c,a+1,1);
                end else z:=z+x;
   end;
   switches:=z;
  end;

  procedure showhisstats;
  begin
    writeln;
    writeln(^R'Your transfer stats are now:');
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;
    writeln;
  end;


  procedure askaboutbye;
  begin
       writeln;
  writestr(^P'[H]'^R'angup after batch, '^P'[A]'^R'bort, '^P'[C/R]'^R' Start Transfer: &');
  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;
      writestr ('Press [Enter] to continue.*');
    end
   else ret_code:=dosexitcode;
  end;

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

  begin
       sod:=false;
       assign(bonzo,'PROT_'+rors+'.DAT');
       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:='c:\workdir\*.*'; 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,wildcatsucks:lstr;
      baudst,commst:mstr;
      retcd:integer; mess:lstr;
      foofur:text; rt:boolean;
      h1,h2,m1,m2,s1,s2,ss1,ss2:word;

  begin

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

    dirsave:=forumdir;
    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);

    writeln;
    writeln(timestr(now),' - Transfer started using ',^S,prdesc,^R,'.');

  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 (xferfile);
     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;
    writeln (^M^J+'Enter a Message regarding the File Request:');
    delay (1000);
    titlestr:='File Request: '+input;
    sendstr:='Sysop';
    m.line:=editor (me,false,'File Request: '+input);
    sendstr:='';
    if m.line<0 then exit;
    m.anon:=false;
    m.title:=titlestr;
    m.sentby:=unam;
    m.when:=now;
    addfeedback (m);
  end;

  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,forumdir+'System.Not');
      if exist (forumdir+'System.Not') then append (n)
      else begin
       rewrite (n);
       writeln (n,'─────────────────────────────────────────────────');
       writeln (n,'[ TCS '+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. TCS 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!');
            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;

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

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

  function checkok (ud:udrec):boolean;
  var m:string;
  begin
   checkok:=true;
    if (not sponsoron) and (ud.points>urec.udpoints) then begin
     writeln (^R'That file requires '^S,ud.points,^R' points!'^R);
     checkok:=false;
     exit
    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 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;
     dots:=true;
     writestr ('Enter Download Password: &');
     dots:=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
      seek (udfile,cnt-1);
      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 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 (ud.descrip);
    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'      Points '^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 Points: '^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,wildcatsucks: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,wildcatsucks: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;
      tcs,bat:udrec;
      ok,cool:boolean;

  begin
  wipedszlog;
   ptsspt:=0;
   oldpts:=urec.udpoints;
   assign (t,b);
   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 (b) 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 [CR/'^S+urec.defproto+^R']? &');
   if length(input)=0 then pro:=urec.defproto else pro:=upcase(input[1]);

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

   askaboutbye;
   if answer='A' then exit;

   writeln; writeln('Starting batch '^S'download'^R' using '^P+prdesc);

   if tempsysop then begin
      ulvl:=regularlevel;
     tempsysop:=false;
     writeurec;
     bottomline
    end;
     begin
     starttimer (mastermind);
     ret_cd:=batchdownload (pro,b,baudrate,usecom);
     modeminlock:=false;
     beepbeep (ret_cd);
     stoptimer (mastermind);
    end;
    if (ret_cd=0) or (ret_cd=1) then begin
     writeln;
     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,tcs);
        tcs.downloaded:=tcs.downloaded+1;
    seekudfile (yyy);
    write (udfile,tcs);

    end;  { yyy }
       urec.udpoints:=urec.udpoints-bat.points;
       ptsspt:=ptsspt+bat.points;
       writelog (15,1,getfname(bat.path,bat.filename));
       write (^R'Completed: '^S);
       tab (bat.filename,13);
       writeln (^R' ('^U,bat.points,' points',^R')');
       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,recv:integer;
      genesis,pro:char;
      fnames,fdescs,fdlpws:btchuparray;
      f:text;
      ud:udrec;
      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);

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 process:boolean; dir1,extend:lstr; f1,f2:text; fn1,fn2:mstr; fn3:lstr;
  begin
    process:=true;
    dir1:=copy(area.xmodemdir,1,length(area.xmodemdir)-1);
    extend:=copy(fnames[tramp],length(fnames[tramp])-3,4);
    extend:=upstring(extend);
    write(^R'Received File: '^S+fnames[tramp]);
    fn1:=forumdir+'PROCNAME.TXT'; fn2:=forumdir+'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('c:\workdir\'+fnames[tramp]) then exit;

    writeln(^R'  posting...');
exec(getenv('COMSPEC'),' /C copy c:\workdir\'+fnames[tramp]+' '+dir1+' >etc.tcs');
exec(getenv('COMSPEC'),' /C del c:\workdir\'+fnames[tramp]+' >etc.tcs');
    ud.path:=area.xmodemdir;
    ud.filename:=fnames[tramp];
    ud.descrip:=fdescs[tramp];
    ud.dlpw:=fdlpws[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.points:=0;
    ud.downloaded:=0;
    ud.newfile:=true;
    ud.specialfile:=false;

    getfsize(ud); 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:='c:\workdir\*.*'; 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'Download P/W for file: *');
            fdlpws[1]:=input;
            end else begin
            fdescs[1]:='U/L with no description';
            fdlpws[1]:='';
            end;
          acceptfile(1);
                        end;
      findnext (ffinfo)
      end;
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.  (15 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]:=input;
     if not sh then begin
       writestr (^R'Description:   *');
       fdescs[fls]:=input;
     end;
     if not sh then begin
       writestr (^R'File Password: *');
       fdlpws[fls]:=input;
     end;
     if sh or (fls=16) then done:=true;
   until done or hungupon;
   end;

   fls:=fls-1;
   clearscr;
   dir:='c:\workdir\';
   listprotocols(3);

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

   askaboutbye;
   if answer='A' then exit;

   xfer:=batchupload (pro,dir,baudrate,usecom);
   writeln (^M^M);
   if (xfer=0) or (xfer=1) then begin
   recv:=checkwork;
   writeln;
   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
     if exist('c:\workdir\'+fnames[cnt]) then acceptfile(cnt);
   getextras;
   end;

   showhisstats;

   if answer='H' then exit;
   end;


  procedure clearbatch;
  var x:integer;
      kaos:text;
  begin
   assign (kaos,b);
   if exist (b) 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:='Zmodem (Forsberg/DSZ)';
       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:=forumdir+pref+'.DAT';  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('PROT_S','- Download Protocols -');
      1 : doprotlist('PROT_R','- Upload Protocols -');
      2 : doprotlist('PROT_D','- Batch Download Protocols -');
      3 : doprotlist('PROT_U','- Batch Upload Protocols -');
      end;
  end;


  procedure batchmenu;
  var i:integer;
  begin
   ansicls;
   b:=forumdir+'Xferlist.TCS';
   writehdr ('TCS 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 Menu','BATCH','DULCK+QR');
      case i of
       1:downbatch;
       2:upbatch;
       3:listbatch;
       4:clearbatch;
       5:killfrombatch;
       6:writeln (^M'Files may only be added in the transfer menu.'^M);
       8:writeln ('There are ',checkwork,' files in the work directory.');
     end;
    until hungupon or (i=7)
  end;

end.