Jason Aller Floppy Collection/153.img/TELES.ZIP/FILESC.PAS

Pascal/Delphi Source File | 1988-07-24 | 38.0 KB | 1,393 lines

{$R-}    {Range checking off}
{ $B+}    {Boolean complete evaluation on}
{$S+}    {Stack checking on}
{$I+}    {I/O checking on}
{$N-}    {No numeric coprocessor}
{$V-}

Unit FileSc;

Interface

Uses
  Crt,
  Dos,
  Common,
  Turbo3,
  Unit1,
  Unit0,
  UnitX;

function dcs:boolean;
procedure idl;
procedure newfiles(b:integer; var abort:boolean);
procedure dlbatch;
procedure lfii;
procedure iul;
procedure unlisted_download(i:astr);
procedure term;
procedure dir(cd,x:astr; all,tf:boolean);
procedure dirf(tf:boolean);
procedure searchb(b:integer; fn:astr; var abort:boolean);
procedure searchbd(b:integer; ts:astr; var abort:boolean);
procedure search;
procedure searchd;
procedure nf;
procedure sort;
procedure yourfileinfo;
procedure listfiles;
procedure remove;
procedure move;
procedure editfiles;
procedure setdirs;
procedure pointdate;
procedure listboards(z:astr);

Implementation

var
  Zmodem:boolean;
  Fpneed:integer;

procedure ansig(x:integer; y:integer);
begin
  pr1(#27+'['+cstr(y)+';'+cstr(x)+'H');
  gotoxy(x,y);
end;


procedure freebytes;
var r:real; regs:registers;
begin
  regs.dx:=0;
  regs.ax:=$36*256;
  MsDos(regs);
  r:=(regs.ax)*(regs.bx)*(regs.cx);
  prompt(cstrr(r,10)+' Bytes');
end;

function dcs:boolean;
begin
  dcs:=cs or (thisuser.dsl>=200);
end;

function stripname(i:astr):astr;
var i1:astr; n:integer;
  function nextn:integer;
  var n:integer;
  begin
    n:=pos(':',i1);
    if n=0 then
      n:=pos('\',i1);
    if n=0 then
      n:=pos('/',i1);
    nextn:=n;
  end;
begin
  i1:=i;
  while nextn<>0 do
    i1:=copy(i1,nextn+1,80);
  stripname:=i1;
end;

function tcheck(s:real; i:integer):boolean;
var r:real;
begin
  r:=timer-s;
  if r<0.0 then r:=r+86400.0;
  if (r<0.0) or (r>32760.0) then r:=32766.0;
  if trunc(r)>i then tcheck:=false else tcheck:=true;
end;

function tchk(s:real; i:real):boolean;
var r:real;
begin
  r:=timer;
  if r<s then r:=r+86400.0;
  if (r-s)>i then tchk:=false else tchk:=true;
end;

function uc(s:astr):astr;
var x:astr; i:integer;
begin
  x:=s;
  for i:=1 to length(s) do
    x[i]:=upcase(x[i]);
  uc:=x;
end;

procedure ymbadd(fn:astr);
var t1,t2:real; f:file; inte:integer;
begin
  nl;
  assign(f,fn); {$I-} reset(f,1024); {$I+}
  if ioresult<>0 then
    print('File doesn''t exist')
  else begin
    inte:=value(spd); if inte=0 then inte:=1200;
    t1:=(filesize(f))*12960.0/inte;
    close(f);
    t2:=ymbtt+t1;
    if t2>nsl then
      print('Not enough time left in queue.')
    else
      if ymodemfiles=20 then
        print('Too many files in queue.')
      else
        begin
        ymodemfiles:=ymodemfiles+1;
        ymbary[ymodemfiles].fn:=fn;
        ymbary[ymodemfiles].tt:=t1;
        ymbtt:=t2;
        print('File added to batch queue.');
        print('Batch - Files: '+cstr(ymodemfiles)+'  Time: '+ctim(ymbtt));
      end;
  end;
  nl;
end;

procedure ymbdel(n:integer);
var c:integer;
begin
  if (n<=ymodemfiles) and (n>0) then begin
    ymbtt:=ymbtt-ymbary[n].tt;
    if n=ymodemfiles then
      ymodemfiles:=ymodemfiles-1
    else begin
      for c:=n to ymodemfiles-1 do begin
        ymbary[c].fn:=ymbary[c+1].fn;
        ymbary[c].tt:=ymbary[c+1].tt;
      end;
      ymodemfiles:=ymodemfiles-1;
    end;
  end;
end;

{$I DLP1.PAS}

function exist(fn:astr):boolean;
var f:file;
begin
  assign(f,fn);
  {$I-} reset(f); {$I+}
  if ioresult=0 then begin close(f); exist:=true end else exist:=false;
end;

function align(fn:astr):astr;
var f,e,t:astr; c,c1:integer;
begin
  c:=pos('.',fn);
  if c=0 then begin
    f:=fn; e:='   ';
  end else begin
    f:=copy(fn,1,c-1); e:=copy(fn,c+1,3);
  end;
  while length(f)<8 do f:=f+' ';
  while length(e)<3 do e:=e+' ';
  if length(f)>8 then f:=copy(f,1,8);
  if length(e)>3 then e:=copy(e,1,3);
  c:=pos('*',f); if c<>0 then for c1:=c to 8 do f[c1]:='?';
  c:=pos('*',e); if c<>0 then for c1:=c to 3 do e[c1]:='?';
  c:=pos(' ',f); if c<>0 then for c1:=c to 8 do f[c1]:=' ';
  c:=pos(' ',e); if c<>0 then for c1:=c to 3 do e[c1]:=' ';
  align:=f+'.'+e;
end;

function fit(f1,f2:astr):boolean;
var tf:boolean; c:integer;
begin
  tf:=true;
  for c:=1 to 12 do
    if (f1[c]<>f2[c]) and (f1[c]<>'?') then tf:=false;
  fit:=tf;
end;

procedure fiscan(var pl:integer);
var f:ulfrec;
begin
  assign(ulff,systat.gfilepath+uboards[FILEBOARD].filename+'.DIR');
  {$I-} reset(ulff); {$I+}
  if ioresult<>0 then begin
    rewrite(ulff);
    f.blocks:=0;
    write(ulff,f);
  end;
  seek(ulff,0);
  read(ulff,f);
  pl:=f.blocks;
  bnp:=false;
end;

procedure recno(fn:astr; var pl,rn:integer);
var c:integer;
    f:ulfrec;
begin
  fn:=align(fn);
  fiscan(pl); rn:=0; c:=1;
  while (c<=pl) and (rn=0) do begin
    seek(ulff,c); read(ulff,f);
    if pos('.',f.filename)<>9 then begin
      f.filename:=align(f.filename);
      seek(ulff,c); write(ulff,f);
    end;
    if fit(fn,f.filename) then rn:=c;
    c:=c+1;
  end;
  lrn:=rn;
  lfn:=fn;
end;

procedure nrecno(fn:astr; var pl,rn:integer);
var c:integer;
    f:ulfrec;
begin
  rn:=0;
  if (lrn<pl) and (lrn>=0) then begin
    c:=lrn+1;
    while (c<=pl) and (rn=0) do begin
      seek(ulff,c); read(ulff,f);
      if pos('.',f.filename)<>9 then begin
        f.filename:=align(f.filename);
        seek(ulff,c); write(ulff,f);
      end;
      if fit(lfn,f.filename) then rn:=c;
      c:=c+1;
    end;
    lrn:=rn;
  end;
end;

procedure pbn(var abort:boolean);
var i,i1:astr; next:boolean;
begin
  if not bnp then begin
    nl;
    i:=#3+#3+uboards[FILEBOARD].name+' '+#3+#2+'#'+#3+#4+cstr(FILEBOARD);
    i1:=#3+#0+'---'; while length(i1)<length(i) do i1:=i1+'-';
    nl; nl;
    printacr(i,abort,next);
    printacr(i1,abort,next);
    nl;
    cl(7); print('Filename     Blks Pts Description');
  end;
  bnp:=true;
end;

procedure dlx(f1:ulfrec; rn:integer; var abort:boolean);
var inte,pl,c:integer; ok,tl:boolean; u:userrec; rl:real; i,ii:astr; Z:INTEGER;
begin
    nl; nl;
    if okansi then begin
      cl(2);prompt('─────────────────────────');
      for z:=1 to (length(f1.description)-13) do
         prompt('─');
      cl(1);
    end;
    nl;
    prompt('Filename   : ');cl(3);print('"'+f1.filename+'"');
    prompt('Description: ');cl(3);print(f1.description);
    prompt('# of blocks: ');cl(5);print(cstr(f1.blocks)+'-'+cstr((f1.blocks+7)div 8));
    prompt('Aprox. time: ');cl(5);print(ctim(rte*f1.blocks));
    reset(uf); seek(uf,f1.owner); read(uf,u); close(uf);
    prompt('U/L''d by   : ');cl(4);print(u.name+' #'+cstr(f1.owner));
    prompt('U/L''d on   : ');cl(4);print(f1.date);
    prompt('Times D/L''d: ');cl(4);print(cstr(f1.nacc));
    prompt('File points: ');cl(4); if (f1.filepoints<>999) and (f1.filepoints<>-1) then
    print(cstr(f1.filepoints)) else begin
    if f1.filepoints=999 then
      begin cl(8); print('<New>'); end else
    begin
      cl(9); print('Ask (Request File)');
    end;
    end;
    if okansi then begin
      cl(2);prompt('─────────────────────────');
         for z:=1 to (length(f1.description)-13) do
         prompt('─');
      cl(1);
    end;
    nl; nl;
    ft:=f1.ft;
    if ft<>255 then print('File type: '+cstr(ft));
    if timer<timeon then timeon:=timeon-24.0*60*60;
    tl:=(nsl>(rte*f1.blocks));
    fpneed:=f1.filepoints;
    if f1.filepoints<>-1 then begin
    if thisuser.filepoints>=f1.filepoints then begin
    if tl then begin
      if exist(uboards[FILEBOARD].dlpath+f1.filename) then begin
        send1(uboards[FILEBOARD].dlpath+f1.filename,ok,abort);
        if ok then begin
          f1.nacc:=f1.nacc+1;
          seek(ulff,rn);
          write(ulff,f1);
        end;
      end else print('File isn''t really there!');
    end else print('Not enough time left to download');
    end else
      if f1.filepoints>998 then print('You can''t download UNVALIDATED files.') else
      print('You don''t have enough file points to download this file.');
    end else print('This is a REQUEST file -- Ask '+systat.sysopfirst+' '+systat.sysoplast+' for it.');
end;

procedure dl(fn:astr);
var pl,rn:integer; f:ulfrec; abort:boolean;
begin
  recno(fn,pl,rn); abort:=false;
  if rn=0 then print('File not found.') else begin
    while (rn<>0) and (not abort) and (not hangup) do begin
      seek(ulff,rn); read(ulff,f); dlx(f,rn,abort);
      nrecno(fn,pl,rn);
    end;
  end;
  close(ulff);
end;

  procedure copyfile(srcname,destname:astr);
var buffer: array[1..16384] of byte;
    dfs,nrec:integer;
    src, dest: file;

    procedure dodate;
    var r:registers; od,ot,ha:integer;
    begin
      srcname:=srcname+#0;
      destname:=destname+#0;
      with r do begin
        ax:=$3d00; ds:=seg(srcname[1]); dx:=ofs(srcname[1]); msdos(Dos.Registers(r));
        ha:=ax; bx:=ha; ax:=$5700; msdos(Dos.Registers(r));
        od:=dx; ot:=cx; bx:=ha; ax:=$3e00; msdos(Dos.Registers(r));
        ax:=$3d02; ds:=seg(destname[1]); dx:=ofs(destname[1]); msdos(Dos.Registers(r));
        ha:=ax; bx:=ha; ax:=$5701; cx:=ot; dx:=od; msdos(Dos.Registers(r));
        ax:=$3e00; bx:=ha; msdos(Dos.Registers(r));
      end;
    end;

begin
  assign(src,srcname); reset(src,1);
  if destname[2]=':' then dfs:=freek(ord(destname[1])-ord('@')) else dfs:=freek(0);
  if trunc(longfilesize(src)/1024.0)+1>=dfs then begin
    print('Disk full.');
    close(src);
  end else begin
    assign(dest,destname); rewrite(dest,1);
    nl; print('Copying...');
    repeat
      blockread(src,buffer,16384,nrec);
      blockwrite(dest,buffer,nrec);
    until nrec<16384;
    close(dest);
    close(src);
    dodate;
  end;
end;

procedure dl1(n:integer);
var f1:ulfrec; abort:boolean;
begin
  nl; nl;
  seek(ulff,n); read(ulff,f1);
  dlx(f1,n,abort);
  nl;
end;

procedure ul(fn:astr);
var x,pl,c,cc,ob,np:integer; f,f1:ulfrec; uls,ok:boolean; fi:file of byte;
begin
 if freek(ord(uboards[FILEBOARD].dlpath[1])-ord('@'))>100 then begin
  uls:=incom;
  ob:=FILEBOARD;
  ok:=true; fn:=align(fn);
  if (fn[1]=' ') or (fn[10]=' ') then ok:=false;
  for x:=1 to length(fn) do
    if not (fn[x] in ['0'..'9','A'..'Z','.',' ','-']) then ok:=false;
  np:=0; for x:=1 to length(fn) do if fn[x]='.' then np:=np+1;
  if np<>1 then ok:=false;
  if ok then
    if incom then
      if exist(uboards[FILEBOARD].dlpath+fn) then
        if dcs then begin
          print('There already is one.');
          ynq('Do it anyways? ');
          ok:=yn;
          uls:=false;
        end else
          ok:=false
      else
        ok:=true
    else
      ok:=exist(uboards[FILEBOARD].dlpath+fn)
  else print('Illegal filename.');
  if (not incom) then
    if ok then print('Am using the file in '+uboards[FILEBOARD].dlpath)
    else begin print('To put in a file from keyboard, it must already be');
               print('present in the dloads directory.'); end;
  nl; nl;
  if ok and incom and uls then begin
    assign(fi,uboards[FILEBOARD].dlpath+fn); {$I-} rewrite(fi); {$I+}
    if ioresult<>0 then begin
      {$I-} close(fi); {$I+} cc:=ioresult;
      ok:=false;
    end else begin close(fi); erase(fi); end;
  end;
  if not ok then print('Can''t use that filename, sorry.') else begin
    fiscan(pl);
    if pl>=uboards[FILEBOARD].maxfiles then print('This directory is full.') else begin
      ynq('Upload "'+fn+'" ? ');
      if yn then begin ok:=true;
        nl; print('Enter a single "\" in front of the description if it');
        print('for the Sysop.');nl;
        print('Please enter a one line description.'); prt(':');
        inputl(f.description,60);
        if (f.description[1]='\') or (rvalidate in thisuser.ac) then begin
          FILEBOARD:=0;
          close(ulff);
          fiscan(pl);
        end;
        if f.description[1]='\' then f.description:=copy(f.description,2,80);
        ok:=true; ft:=255;
        if uls then receive1(uboards[FILEBOARD].dlpath+fn,ok);
        nl; nl;
        if not ok then print('Not saved.') else begin
          f.filename:=fn;
          f.owner:=usernum;
          f.date:=date;
          f.daten:=daynum(date);
          for x:=1 to 17 do f.res[x]:=0;
          f.ft:=ft;
          f.nacc:=0;
          assign(fi,uboards[FILEBOARD].dlpath+fn);
          {$I-} reset(fi); {$I+}
          if ioresult=0 then begin
            f.filepoints:=999;
            f.blocks:=trunc((longfilesize(fi)+127.0)/128.0);
            close(fi);
            for x:=pl downto 1 do begin
              seek(ulff,x); read(ulff,f1);
              seek(ulff,x+1); write(ulff,f1);
            end;
            seek(ulff,1);
            write(ulff,f);
            seek(ulff,0); read(ulff,f); f.blocks:=pl+1;
            seek(ulff,0); write(ulff,f);
            sysoplog('Uploaded "'+fn+'" on '+uboards[FILEBOARD].name);
            print('File successfully uploaded.');nl;cl(3);
            {print('Download credits granted.');}
          end else begin
            print('System Error.  Not saved.');
            sysoplog('Error uploading "'+fn+'"');
          end;
        end;
      end;
    end;
    close(ulff); FILEBOARD:=ob;
  end;
  nl; nl;
  end else begin
    nl; nl; print('Sorry, not enough disk space.');
    nl;
  end;
end;

procedure idl;
var i:astr; down:boolean;
begin
  down:=true;
  if systat.dllowtime<>systat.dlhitime then begin
    if systat.dlhitime>systat.dllowtime then begin
      if (timer<=(systat.dllowtime*60.0)) or (timer>=(systat.dlhitime*60.0))
        then down:=false;
    end else begin
      if (timer<=(systat.dllowtime*60.0)) and (timer>=(systat.dlhitime*60.0))
        then down:=false;
    end;
  end;
  if spd='300' then begin
    if systat.b300dllowtime<>systat.b300dlhitime then begin
      if systat.b300dlhitime>systat.b300dllowtime then begin
        if (timer<=(systat.b300dllowtime*60.0)) or (timer>=(systat.b300dlhitime*60.0))
          then down:=false;
      end else begin
        if (timer<=(systat.b300dllowtime*60.0)) and (timer>=(systat.b300dlhitime*60.0))
          then down:=false;
      end;
    end;
  end;
  if not down then printfile(systat.gfilepath+'dlhours.msg');
  if down then begin
    nl; print('You have '+cstr(thisuser.filepoints)+' file points.');
    nl; print('Download -'); nl; prt('Enter filename: '); mpl(12); input(i,12);
    dl(i);
    nl; nl;
  end;
end;

procedure iul;
var i:astr;
begin
  nl; nl; print('Upload -'); nl; prt('Enter filename: '); mpl(12); input(i,12);
  ul(i);
  nl;
end;

procedure setdta;
var r:registers;
begin
  r.ds:=seg(dta[1]);
  r.dx:=ofs(dta[1]);
  r.ax:=$1a00;
  msdos(Dos.Registers(r));
end;

function vdir(var d:astr):boolean;
begin
  if d[length(d)]='\' then d:=copy(d,1,length(d)-1);
  vdir:=true;
end;

procedure fix(var fn:astr);
var i,i1:astr; c1,c2:integer; ok:boolean;
begin
  if vdir(fn) then fn:=fn+'\';
  c1:=pos('\',fn); ok:=true;
(*  if c1<>0 then begin
    i:=copy(fn,1,c1-1);
    fn:=copy(fn,c1+1,15);
    if not vdir(i) then ok:=false;
  end else i:='';*)
  if i='' then i:=uboards[FILEBOARD].dlpath;
  if fn='' then fn:='*.*';
  fn:=i+'\'+align(fn);
(*  if (pos('.MSG',fn)=0) and (pos('.TXT',fn)=0) and (pos('?',fn)=0) and (not so) then ok:=false;*)
  if not ok then fn:='';
end;

procedure ffile(fn:astr);
var r:registers; c:integer;
begin
  for c:=0 to 80 do dta[c]:=#0;
  setdta;
  filenamef:=fn+#0;
  r.ds := seg(filenamef[1]);
  r.dx := ofs(filenamef[1]);
  r.ax := $4e00;
  r.cx := 0;
  msdos(Dos.Registers(r));
  if r.ax=0 then found:=true else found:=false;
end;

procedure nfile;
var r:registers;
begin
  r.ax:=$4f00;
  msdos(Dos.Registers(r));
  if r.ax=0 then found:=true else found:=false;
end;

function fname:astr;
var i1:astr; c1:integer;
begin
  i1:=''; c1:=31;
  while (dta[c1]<>#0) and (c1<44) do begin i1:=i1+dta[c1]; c1:=c1+1; end;
  fname:=i1;
end;

function ti(i:integer):astr;
var i1:astr;
begin
  str(i,i1);
  if length(i1)=1 then i1:='0'+i1;
  ti:=i1;
end;

function info:astr;
var res,i1,f,e:astr; c1,c2:integer; rl:real;
begin
  i1:=fname;
  if (ord(dta[22]) and $10)=$10 then begin
    res:=i1;
    while length(res)<13 do res:=res+' ';
    res:=res+'<DIR>   ';
    e:='';
  end else begin
    c1:=pos('.',i1);
    if c1=0 then begin
      res:=i1;
      while length(res)<12 do res:=res+' ';
    end else begin
      f:=copy(i1,1,c1-1); e:=copy(i1,c1+1,3);
      while length(f)<8 do f:=f+' ';
      while length(e)<3 do e:=e+' ';
      res:=f+' '+e;
    end;
    rl:=0;
    for c1:=30 downto 27 do
      rl:=(rl*$100)+ord(dta[c1]);
    i1:=cstrr(rl,10);
  while length(i1)<9 do i1:=' '+i1;
    res:=res+i1;
  end;
  c1:=ord(dta[26])*$100+ord(dta[25]);
  i1:=cstr((c1 shr 5) mod 16); if i1[0]=#1 then i1:=' '+i1;
  i1:=i1+'-'+ti(c1 mod 32)+'-'+ti(80+(c1 shr 9));
  res:=res+'  '+i1+'  ';
  c1:=ord(dta[24])*$100+ord(dta[23]);
  c2:=(c1 shr 11);
  if (c2<12) then f:='a' else begin f:='p'; c2:=c2-12; end;
  if c2=0 then c2:=12;
  i1:=cstr(c2); if i1[0]=#1 then i1:=' '+i1;
  res:=res+i1+':'+ti((c1 shr 5) mod 64)+f;
  info:=res;
end;

procedure dir(cd,x:astr; all,tf:boolean);
var
  abort,next:boolean;
  x1,xx:astr; dfs,kk:integer;
begin
  cd:=uboards[FILEBOARD].dlpath;
  nl;print('Directory of '+copy(cd,1,length(cd)-1));
  xx:='';kk:=0;
  ffile(cd+x);
  nl; abort:=false;
  while found and not abort do begin
    x1:=align(fname);
  if tf then
    printacr(info,abort,next)
      else
        begin
          kk:=kk+1;if kk=5 then xx:=xx+x1 else xx:=xx+x1+'    ';
          if kk=5 then begin printacr(xx,abort,next);kk:=0;xx:='';end;
        end;
    nfile;
  end;
  if (not found) and (kk>0) and (kk<6) then printacr(xx,abort,next);
  if cd[2]=':' then dfs:=freek(ord(cd[1])-ord('@')) else dfs:=freek(0);
  nl; printacr('  Free space = '+#3+#3+cstr(dfs)+#3+#1+'k',abort,next);
end;

procedure dirf(tf:boolean);
begin
  all:=false;
  if not (vdir(ix[2]) or (ix[2]='')) and so then all:=true;
  fix(ix[2]);
(*  c1:=pos('\',ix[2]);
  s1:=copy(ix[2],1,c1-1);
  s2:=copy(ix[2],c1+1,12);
  if s1='' then s1:=uboards[FILEBOARD].dlpath; *)
  s1:=uboards[FILEBOARD].dlpath;
  s2:='*.*';
  nl; dir(s1,s2,all,tf);
end;

procedure gfn(var fn:astr);
begin
  nl;
  print('<CR>=all files');
  prt('File mask: '); input(fn,12);
  if fn='' then fn:='*.*';
  fn:=align(fn);
end;

function aln(i:astr; n:integer):astr;
begin
  while length(i)<n do i:=' '+i;
  aln:=i;
end;

procedure pfn(f:ulfrec; var abort,next:boolean);
var i:astr;
  begin
  i:=#3+#3+f.filename+#3+#2+':'+#3+#4+aln(cstr(f.blocks),4)+#3+#2+':';
  if (f.filepoints<>999) and (f.filepoints<>-1) then i:=i+#3+#4+aln(cstr(f.filepoints),3) else begin
    if f.filepoints=999 then i:=i+#3+#8+'New';
    if f.filepoints=-1 then i:=i+#3+#9+'Ask';
  end;
  i:=i+#3+#2+':'+#3+#5+copy(f.description,1,55); if length(f.description)>55 then i:=i+#3+#3+'+';
  printacr(i,abort,next);
end;

procedure searchb(b:integer; fn:astr; var abort:boolean);
var oldboard,pl,rn:integer; f:ulfrec;
begin
  oldboard:=FILEBOARD; FILEBOARD:=b;
  recno(fn,pl,rn);
  while (rn<=pl) and (not abort) and (not hangup) and (rn<>0) do begin
    seek(ulff,rn); read(ulff,f);
    pbn(abort);
    pfn(f,abort,next);
    nrecno(fn,pl,rn);
  end;
  close(ulff);
  FILEBOARD:=oldboard;
end;

procedure searchbd(b:integer; ts:astr; var abort:boolean);
var oldboard,pl,rn:integer; f:ulfrec; next:boolean;
begin
  oldboard:=FILEBOARD; FILEBOARD:=b; fiscan(pl);
  rn:=1;
  while (rn<=pl) and (not abort) and (not hangup) do begin
    seek(ulff,rn); read(ulff,f);
    if pos(ts,uc(f.description))<>0 then begin
      pbn(abort);
      pfn(f,abort,next);
    end;
    rn:=rn+1;
  end;
  close(ulff);
  FILEBOARD:=oldboard;
end;

procedure search;
var fn:astr; bn:integer; abort:boolean;
begin
  nl; nl; print('Search all directories.');
  gfn(fn);
  bn:=0; abort:=false;
  while (not abort) and (bn<=maxulb) and (not hangup) do begin
    if (thisuser.dsl>=uboards[bn].dsl) and (thisuser.age>=uboards[bn].agereq)
    and (uboards[bn].ar='@') or (uboards[bn].ar in thisuser.ar)
         then
     searchb(bn,fn,abort);
    bn:=bn+1;
  end;
end;

procedure searchd;
var fn:astr; bn:integer; abort:boolean;
begin
  nl; nl; print('Find a description -'); nl;
  print('Enter what to search description for.');
   abort:=false;
  prt(': '); input(fn,20);
  if fn<>'' then begin
    nl; print('Searching for "'+fn+'"'); nl;
    ynq('Search all directories? ');
    if yn then begin
      bn:=0;
      while (not abort) and (bn<=maxulb) and (not hangup) do begin
      if (thisuser.dsl>=uboards[bn].dsl) and (thisuser.age>=uboards[bn].agereq)
      and (uboards[bn].ar='@') or (uboards[bn].ar in thisuser.ar)
           then
         searchbd(bn,fn,abort);
        bn:=bn+1;
      end;
    end else searchbd(FILEBOARD,fn,abort);
  end;
end;

procedure newfiles(b:integer; var abort:boolean);
var oldboard,pl,rn,ldn:integer; f:ulfrec; next:boolean;
begin
  oldboard:=FILEBOARD; FILEBOARD:=b; fiscan(pl);
  ldn:=daynum(ldat);
  rn:=1;
  while (rn<=pl) and (not abort) and (not hangup) do begin
    seek(ulff,rn); read(ulff,f);
    if f.daten>=ldn then begin
      pbn(abort);
      pfn(f,abort,next);
    end;
    rn:=rn+1;
  end;
  close(ulff);
  FILEBOARD:=oldboard;
end;

procedure nf;
var bn:integer; abort:boolean;
begin
  nl; print('Search for new files.'); nl;
  ynq('Search all directories? ');
  if yn then begin
    bn:=0; abort:=false;
    while (not abort) and (bn<=maxulb) and (not hangup) do begin
      if (thisuser.dsl>=uboards[bn].dsl) and (bn in thisuser.dlnscn) and
      (thisuser.age>=uboards[bn].agereq) and (uboards[bn].ar='@')
      and (uboards[bn].key<>'%')
      or (uboards[bn].ar in thisuser.ar) then newfiles(bn,abort);
      bn:=bn+1;
    end;
  end else newfiles(FILEBOARD,abort);
end;

procedure deleteff(rn:integer; var pl:integer);
var f:ulfrec; i:integer;
begin
  if (rn<=pl) and (rn>0) then begin
    pl:=pl-1;
    for i:=rn to pl do begin
      seek(ulff,i+1); read(ulff,f);
      seek(ulff,i); write(ulff,f);
    end;
    seek(ulff,0); f.blocks:=pl; write(ulff,f);
  end;
end;

function gtr(f,f1:ulfrec):boolean;
begin
  if sortbd and (f1.daten<>f.daten) then
    if f1.daten<f.daten then
      gtr:=false
    else
      gtr:=true
  else
    if f1.filename>f.filename then
      gtr:=false
    else
      gtr:=true;
end;

procedure sortd(c:integer);
var oldboard,trn,srn,i,i1,pl:integer; f,f1:ulfrec;
begin
  oldboard:=FILEBOARD; FILEBOARD:=c; fiscan(pl);
  nl; print('Sorting '+uboards[FILEBOARD].name);
  for i:=1 to pl-1 do begin
    seek(ulff,i); read(ulff,f); trn:=i;
    for i1:=i+1 to pl do begin
      seek(ulff,i1); read(ulff,f1);
      if gtr(f,f1) then begin
        f:=f1; trn:=i1;
      end;
    end;
    seek(ulff,i); read(ulff,f1); seek(ulff,i);
    write(ulff,f); seek(ulff,trn); write(ulff,f1);
  end;
  close(ulff);
  FILEBOARD:=oldboard;
end;

procedure sort;
var bn:integer;
begin
  nl; nl; ynq('Sort by date? '); if yn then sortbd:=true else sortbd:=false;
  nl; ynq('Sort all boards? ');
  if yn then
    for bn:=0 to maxulb do
      sortd(bn)
  else
    sortd(FILEBOARD);
end;

procedure yourfileinfo;
begin
  if okansi then begin
    cls;
    nl;
    cl(0); print('  File points: ');
    cl(0); print('      Your SL: ');
    cl(0); print('     Your DSL: ');
    cl(0); print('    You D/L''d: ');
    cl(0); print('    You U/L''d: ');
    cl(5); ansig(16,2); prompt(cstr(thisuser.filepoints));
    cl(5); ansig(16,3); prompt(cstr(thisuser.sl));
    cl(5); ansig(16,4); prompt(cstr(thisuser.dsl));
    cl(5); ansig(16,5); prompt(cstr(thisuser.dk)+'K in '+cstr(thisuser.downloads)+' files');
    cl(5); ansig(16,6); prompt(cstr(thisuser.uk)+'K in '+cstr(thisuser.uploads)+' files');
  end else begin
  nl; nl;
  print('File pts  : '+cstr(thisuser.filepoints));
  print('Your SL   : '+cstr(thisuser.sl));
  print('Your DSL  : '+cstr(thisuser.dsl));
  print('You D/L''d : '+cstr(thisuser.dk)+'K in '+cstr(thisuser.downloads)+' files');
  print('You U/L''d : '+cstr(thisuser.uk)+'K in '+cstr(thisuser.uploads)+' files');
  end;
end;

procedure listfiles;
var abort:boolean; fn:astr;
begin
  nl; nl; print('List files.');
  gfn(fn); abort:=false;
  searchb(FILEBOARD,fn,abort);
end;

procedure listf(n:integer; var abort:boolean);
var f:ulfrec; i,i1:astr; next:boolean;
begin
  seek(ulff,n); read(ulff,f);
  i:=#3+#4+cstr(n); while length(i)<5 do i:=' '+i;
  i:=i+#3+#2+': '+#3+#3+f.filename;
  while length(i)<24 do i:=i+' ';
  i1:=cstr(f.blocks); while length(i1)<5 do i1:=' '+i1; i:=i+i1;
  i:=i+'  '+f.date+'  '; i1:=cstr(f.owner); while length(i1)<3 do i1:=' '+i1;
  i:=i+i1;
  printacr(i,abort,next);
end;

{$I dlp2.pas}

procedure local_input1(var i:astr; ml:integer; tf:boolean);
var cp:integer;
    cc:char;
    r:real;
begin
  cp:=1;
  repeat
    cc:=readkey;
    if not tf then cc:=upcase(cc);
    if (cc>=' ') and (cc<chr(127)) then
      if cp<=ml then begin
      i[cp]:=cc;
      cp:=cp+1;
      write(cc);
    end else else case ord(cc) of
      8:if cp>1 then begin
               cc:=chr(8);
               write(cc);write(' '); write(cc);
               cp:=cp-1;
             end;
      21,24:while cp<>1 do begin
               cp:=cp-1;
               write(#8);write(' ');write(#8);
             end;
      end;
  until (cc=#13) or (cc=#14);
  i[0]:=chr(cp-1);
  writeln;
end;

procedure local_input(var i:astr; ml:integer);  (* Input uppercase only *)
begin
  local_input1(i,ml,false);
end;

procedure local_inputl(var i:astr; ml:integer);   (* Input lower & upper case *)
begin
  local_input1(i,ml,true);
end;

procedure term;
var c:char; done,bac,eco,LFEEDS:boolean;
    hs:byte;
    ns:array[1..9] of pnr;
    fil:file of pnr;
    lnd,i:integer;
    maxs:byte;
    rl:real;
    r:registers;

procedure ul;
var dok,abort:boolean; i:astr; f:file;
begin
  writeln; writeln; ft:=255;
  prompt('Send file: ');
  input(i,70);
  assign(f,i);
  {$I-} reset(f); {$I+}
  if ioresult=0 then begin
    close(f);
    send1(i,dok,abort);
  end else print('File not found.');
  incom:=false;
  hangup:=false;
  outcom:=false;
  writeln;
end;

procedure dl;
var dok:boolean; i:astr; f:file;
begin
  writeln; writeln; ft:=255;
  prompt('Receive file: ');
  input(i,70);
  assign(f,i);
  {$I-} reset(f); {$I+}
  if ioresult<>0 then begin
    {$I-} rewrite(f); {$I+}
    if ioresult=0 then begin
      close(f);
      dok:=true;
    end else begin
      dok:=false;
      print('Illegal filename.');
    end;
  end else begin
    close(f);
    print(#7+'File already exists.');
    prompt('Overwrite? ');
    dok:=yn;
  end;
  if dok then
    receive1(i,dok);
  hangup:=false;
  incom:=false;
  outcom:=false;
end;

  procedure pc(s:astr);
  var i:integer;
  begin
    s:=s+chr(13);
    for i:=1 to length(s) do o1(s[i]);
  end;

  procedure cs(hs:byte);
  begin
    writeln;
    case hs of
      0:begin
          set_baud(300);
          tc(1);write('--- ');tc(3);write('300 BAUD ');tc(1);writeln('---');
        end;
      1:begin
          set_baud(1200);
          tc(1);write('=== ');tc(3);write('1200 BAUD');tc(1);writeln(' ===');
        end;
      2:begin
          set_baud(2400);
          tc(1);write('=-=');tc(3);write(' 2400 BAUD ');tc(1);writeln('=-=');
        end;
      3:begin
          set_baud(4800);
          tc(1);write('=*=');tc(3);write(' 4800 BAUD ');tc(1);write('=*=');
        end;
      4:begin
          set_baud(9600);
          tc(1);write('*=*');tc(3);write(' 9600 BAUD ');tc(1);write('*=*');
        end;
      end;
    writeln;
  end;

  procedure tab(x:integer);
  begin
    while wherex<x do write(' ');
  end;

  procedure dial;
  var i:integer; done:boolean; c:char; s:astr;
  begin
    done:=false;
    repeat
      writeln;
      tc(10);
      write('Dial: ');tc(11);write('1-9,M,Q,? : ');tc(2);
      repeat
        read(kbd,c); c:=upcase(c);
      until c in ['1'..'9','M','Q','?'];
      writeln(c); writeln;
      if c='Q' then begin done:=true; writeln; writeln('Back in term mode.'); writeln; end;
      if c='?' then begin
        clrscr;
        tc(15);writeln('N NAME                                      NUMBER         SPD');
        tc(9);writeln('─ ────────────────────────────────────────  ─────────────  ────');
        for i:=1 to 9 do begin
          tc(11);write(i,' ');tc(14);
          WRITE(ns[i].name); tab(45); tc(15);write(ns[i].number); tc(3);tab(60);
          case ns[i].hs of
            0:writeln(' 300');
            1:writeln('1200');
            2:writeln('2400');
          end;
        end;
      end;
      if c='M' then begin
        write('Which (1-9) ? ');
        repeat
          read(kbd,c);
        until c in ['1'..'9',#13];
        if c in ['1'..'9'] then begin
          i:=value(c);
          clrscr;
          writeln('Number: ',i);
          writeln;
          tc(14);writeln('Old Name: ',ns[i].name);
          tc(11);write('New Name: ');MPL(40); inputl(s,40);
          if s<>'' then ns[i].name:=s;
          writeln;
          tc(14);writeln('Old Number: ',ns[i].number);
          tc(11);write('New Number: '); MPL(40);input(s,14);
          if s<>'' then ns[i].number:=s;
          writeln;
          tc(14);write('Old Speed: ');
          case ns[i].hs of
            0:writeln(' 300');
            1:writeln('1200');
            2:writeln('2400');
          end;
          writeln;tc(11);
          writeln('0 =  300');
          if maxs>0 then writeln('1 = 1200');
          if maxs>1 then writeln('2 = 2400');
          write('New speed? '); read(kbd,c); if (c<'0') or (c>'2') then c:=#0;
          writeln(c); writeln;
          if (value(''+c)<=maxs) and (c<>#0)  then ns[i].hs:=value(''+c);
          reset(fil); seek(fil,i-1); write(fil,ns[i]); close(fil);
          c:=' ';
        end;
      end;
      if c in ['1'..'9'] then begin
        done:=true;
        i:=value(c);
        clrscr; lnd:=i;
        hs:=ns[i].hs; cs(hs);
        tc(14);writeln('Dialing: ',ns[i].name);tc(11);
        writeln('At     : ',ns[i].number);
        writeln;
        pc('ATDT'+ns[i].number);
      end;
    until done;
  end;

  function cdet:boolean;
  begin
    cdet:=((port[base+6] and 128)<>0)
  end;

  procedure hang;
  var rl:real;
  begin
    dump;
    term_ready(false); rl:=timer;
    while cdet and (abs(timer-rl)<1.5) do;
    term_ready(true);
  end;

  procedure redial;
  var c:char; done:boolean; try:integer; rl,rl1,rl2:real; int:integer; i,i1:astr;
  begin
    clrscr; try:=0;
    hs:=ns[lnd].hs; cs(hs); rl:=timer;
    pc('ATM0Q0V0E0S7=16');
    tc(14);writeln('Re-Dialing: ',ns[lnd].name);tc(11);
    writeln('At        : ',ns[lnd].number);
    writeln('Try       : 0');
    writeln('Time      : 00:00');
    writeln; writeln('Hit <ESC> to abort'); done:=false;
    delay(500); dump;
    repeat
      pc('ATDT'+ns[lnd].number);
      try:=try+1;
      gotoxy(13,6); writeln(try);
      rl1:=timer; if rl1<rl then rl:=rl+24.0*3600.0;
      rl2:=abs(rl1-rl); if rl2>32000 then rl2:=32000;
      int:=trunc(rl2);
      i:=cstr(int div 60);
      if length(i)=1 then i:='0'+i;
      i1:=cstr(int mod 60);
      if length(i1)=1 then i1:='0'+i1;
      i:=i+':'+i1;
      gotoxy(13,7); writeln(i); dump;
      while (not done) and (not commpressed) do begin
        if keypressed then begin
          read(kbd,c); if c=#27 then begin done:=true; o1('A'); end;
        end;
      end;
      delay(100);
      if cdet then done:=true else dump;
    until done;
    if cdet then for try:=1 to 6 do begin
      sound(1200); delay(200); nosound; delay(100);
    end else begin
      delay(500); pc('ATM1Q0V1E1S7=30');
    end;
    gotoxy(1,14); writeln; writeln('Back in term mode...');
  end;

procedure help;
  var x,y,c:integer;
  begin
    x:=wherex; y:=wherey;
    tc(4);
    for c:=1 to 12 do begin
      gotoxy(42,c); write(#$b3);
    end;
    gotoxy(42,13); write(#$c0);
    while wherex<>1 do write(#$c4);
    window(43,1,80,12); clrscr;
    window(45,1,80,12); gotoxy(1,1);
    tc(15);
    writeln('Alt-B = backspacing toggle');
    writeln('Alt-C = clear screen');
    writeln('Alt-D = dial number');
    writeln('Alt-E = echo toggle');
    writeln('Alt-H = hang up phone');
    writeln('Alt-Q = redial last number');
    writeln('Alt-S = speed toggle');
    writeln('Alt-X = exit');
    writeln('Alt-L = line feeds toggle');
    writeln('Alt-R = Shell to DOS');
    writeln('PgUp  = send file from dloads');
    write('PgDn  = receive file into dloads');
    window(1,1,80,25); gotoxy(x,y); tc(3);
  end;

procedure om(ch:char);
  begin
    r.ax:=$0200;
    r.dx:=ord(ch);
    msdos(r);
  end;

procedure pp(s:astr);
  var i:integer;
  begin
    for i:=1 to length(s) do
      if s[i]='{' then o1(#13) else o1(s[i]);
  end;

var geei,geez,golly,len:integer; geeg,xx:astr;
begin
  window(1,1,80,25);
  LFEEDS:=FALSE;
  clrscr; lnd:=0; eco:=false;
  if systat.maxbaud=300 then maxs:=0;
  if systat.maxbaud=1200 then maxs:=1;
  if systat.maxbaud=2400 then maxs:=2;
  if systat.maxbaud=4800 then maxs:=3;
  if systat.maxbaud=9600 then maxs:=4;
  assign(fil,systat.gfilepath+'numbers.dat');
  reset(fil);
  for i:=1 to 9 do read(fil,ns[i]);
  close(fil); tc(1);
     writeln('┌────────────────────────────────┐');
      write('│ ');tc(11);write('Telegard Mini-Term Version 1.4');
      tc(1);writeln(' │');
      writeln('└────────────────────────────────┘'); writeln;
     tc(10);write('  Press ');tc(11);WRITE('[');tc(14);WRITE('HOME');
  tc(11);WRITE(']');tc(10);WRITELN(' for help');
  writeln;
  hs:=maxs; cs(hs); bac:=false;
  done:=false;
  pc('ATQ0V1E1S2=43M1S11=50');
  rl:=timer;
  repeat
    if commpressed then begin
      c:=cinkey;
      IF (C=CHR(13)) AND (LFEEDS) THEN WRITELN;
      if c=chr(12) then clrscr else
        if c=chr(8) then begin
          om(c);
          if bac then begin
            om(' '); om(#8);
          end;
        end
      else
        if c<>chr(0) then om(c);
    end else begin
      if timer<rl then rl:=rl-24.0*3600.0;
      if timer-rl>10.0*60.0 then done:=true;
    end;
    if keypressed then begin
      read(kbd,c);
      if c=chr(27) then
        if keypressed then begin
          read(kbd,c); case ord(c) of
            48:begin bac:=not bac; writeln; writeln;
                 if bac then writeln('-Destructive-') else writeln('=Non-Destructive=');
                 writeln; writeln;
               end;
            44:begin
                 clrscr;
                 gotoxy(27,12); returna:=true;
                 write('Returning to WFC & Answering Phone'); done:=true;
               end;
            45:begin
                 clrscr; gotoxy(32,12); returna:=false;
                 write('Returning to WFC ...'); done:=true; end;
            59..67:begin geei:=(ord(c)-58);pp(SYSTAT.SYSOPMACRO[GEEI]);END;
            68:begin
                nl;nl;
                clrscr;
                for geei:=1 to 9 do begin
                  tc(11);
                  write(cstr(geei)+'] '); tc(9);
                  if systat.sysopmacro[geei]='' then systat.sysopmacro[geei]:='[Blank]';
                  writeln(systat.sysopmacro[geei]);
                end;
                tc(14); writeln;
                write('Change which macro? '); local_input(xx,1); geez:=value(xx);
                if geez in [1..9] then begin
                  writeln; writeln('Enter macro now, "{"=<CR>');
                  writeln;tc(9);write(':');tc(11);
                  readln(geeg);systat.sysopmacro[geez]:=geeg;writeln;writeln;
                end;
              end;
            31:begin hs:=hs+1; if hs>maxs then hs:=0; cs(hs); end;
            32:dial;
            38:begin WRITELN;WRITELN;if lfeeds then BEGIN
                WRITELN('=- LINE FEEDS OFF -=');LFEEDS:=FALSE;END ELSE BEGIN
                WRITELN('-= LINE FEEDS ON =-');LFEEDS:=TRUE;END;WRITELN;WRITELN;END;
            16:if (lnd>0) and (lnd<10) then redial;
            19:SysopShell;
            35:begin writeln; writeln('Hanging up...'); writeln; hang; hang; hang; hang; end;
            73:ul;
            75:if okansi then pp(#27+'[D');
            77:if okansi then pp(#27+'[C');
            72:if okansi then pp(#27+'[A');
            80:if okansi then pp(#27+'[B');
            27:pp(#27);
            81:dl;
            71:help;
            46:clrscr;
            18:begin eco:=not eco; writeln; writeln;
                 if eco then writeln('-= ECHO ON =-') else writeln('=- ECHO OFF -=');
                 writeln; writeln;
               end;
          end;
        end else
          om(c)
      else begin o1(c); if eco then om(c); end;
    rl:=timer;
    end;
  until done;
  hang; delay(1000); pc('ATS0=0Q0V0E0M0S2=1S7=30'); delay(100); dump;
end;

procedure lfi(fn:astr; var abort:boolean);
var next:boolean; i1,i2:astr;
begin
  if exist(uboards[FILEBOARD].dlpath+fn) and (not abort) then
    if (pos('.ARC',fn)<>0) or (pos('.LBR',fn)<>0) then begin
      nl;
      i1:=align(fn); i2:=''; while length(i1)>length(i2) do i2:=i2+'-';
      printacr(i1,abort,next);
      printacr(i2,abort,next);
      nl;
      if not abort then begin
        if pos('.ARC',fn)<>0 then arcl(uboards[FILEBOARD].dlpath+fn,abort);
        if pos('.LBR',fn)<>0 then lbrl(uboards[FILEBOARD].dlpath+fn,abort);
      end;
      nl;
    end;
end;

procedure lfin(rn:integer; var abort:boolean);
var f:ulfrec;
begin
  seek(ulff,rn); read(ulff,f); lfi(f.filename,abort);
end;

procedure lfii;
var fn:astr; pl,rn:integer; abort:boolean;
begin
  nl; print('Enter file to list interior files of');
  prt(': '); mpl(12); input(fn,12);
  recno(fn,pl,rn);
  abort:=false;
  if rn=0 then print('File not found.') else begin
    while (rn<>0) and (not abort) do begin
      lfin(rn,abort);
      nrecno(fn,pl,rn);
    end;
  end;
  close(ulff);
end;

Procedure Unlisted_Download(i:astr);
var dok,abort:boolean; f:file;
begin
  ft:=255;
  assign(f,i);
  {$I-} reset(f); {$I+}
  if ioresult=0 then begin
    close(f);
    send1(i,dok,abort);
  end else print('File not found.');
end;

END.