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

Pascal/Delphi Source File | 1988-07-24 | 16.7 KB | 529 lines

procedure arcl(fn:astr; var abort:boolean);
type ei=record l,h:integer; end;
     archead=record
               name:array[1..13] of char;
               size:ei;
               date,time,crc:integer;
               len:ei;
             end;
var f:file; b:byte;
    head:archead;
    done,next:boolean;

  function unsigned(i:integer):real;
  begin
    if i>=0 then
      unsigned:=int(i)
    else
      unsigned:=65536.0+int(i);
  end;

  function valueei(x:ei):real;
  var rl:real;
  begin
    rl:=unsigned(x.h)*65536.0+unsigned(x.l);
    if rl>=32768.0*65536.0 then
      rl:=65536.0*65536.0-rl+1;
    valueei:=rl;
  end;

  function tw(n : integer):astr;
    var s : string[2];
    begin
      s:=cstr(n);
      while length(s)<2 do
        s:='0'+s;
      tw:=s;
    end;

  function fourhex(n : integer):astr;
    var h : integer;
        i : integer;
        he : astr;
    const hexdigit : array [0..15] of char = '0123456789ABCDEF';
    begin
      he:='';
      for i := 1 to 4 do begin
        h := (n shr 12) and $000F;
        he:=he+hexdigit[h];
        n := n shl 4
      end;
      fourhex:=he;
    end;

  procedure pfn;
  var i,i1:astr; try,press:byte; dy,mo,yr,hh,mm,ss:integer;
  const mon : array [1..12] of string[3] =
    ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
      'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
  begin
    b:=0; try:=0;
    while not eof(f) and (b<>26) and (try<5) do begin
      blockread(f,b,1);
      try:=try+1;
    end;
    if try>=5 then longseek(f,filesize(f)-2.0);
    if longfilepos(f)+27<longfilesize(f) then begin
{! 31. ^LongFile operations are no longer available in Turbo 4.0.}
      blockread(f,press,1);
      if press<>0 then begin
          if press=1 then begin
            blockread(f,head,sizeof(head)-sizeof(ei));
            head.len:=head.size;
            end
        else
            blockread(f,head,sizeof(head));
        i:=''; b:=1;
        while (head.name[b]<>#0) and (b<=13) do begin
          i:=i+head.name[b];
          b:=b+1;
          end;
        i:=align(i)+' ';
        i1:=cstrr(valueei(head.len),10);
        while length(i1)<9 do i1:=' '+i1;
        i:=i+i1+'  ';

        case press of
          1    : i:=i+'1  Stored ';
          2    : i:=i+'2  Stored ';
          3    : i:=i+'3  Packed ';
          4    : i:=i+'4 Squeezed';
          5    : i:=i+'5 crunched';
          6    : i:=i+'6 Crunched';
          7    : i:=i+'7 Crunched';
          8    : i:=i+'8 Crunched';
          9    : i:=i+'9 Squashed'
        else begin
                 i1:=cstr(press);
                 while length(i1)<2 do
                    i1:=i1+' ';
                 i:=i+i1+' Unknown';
                 end;
            end;
        i1:=cstr(100 - trunc(100.0 * valueei(head.size) / valueei(head.len)));
        while length(i1)<5 do
            i1:=' '+i1;
        i:=i+i1+'%  ';
        i1:=cstrr(valueei(head.size),10);
        while length(i1)<8 do i1:=' '+i1;
        i:=i+i1+'  ';

        yr:=(head.date shr 9)  and $7f;
        mo:=(head.date shr 5)  and $0f;
        dy:= head.date         and $1f;
        hh:=(head.time shr 11) and $1f;
        mm:=(head.time shr 5 ) and $3f;
        ss:=(head.time         and $1f) * 2;

        i:=i+tw(dy)+' '+mon[mo]+' '+tw((yr+80) mod 100)+'  ';
        i:=i+tw(hh)+':'+tw(mm)+':'+tw(ss)+'  ';
        i:=i+fourhex(head.crc);

        printacr(i,abort,next);
      end else done:=true;
      longseek(f,longfilepos(f)+valueei(head.size));
{! 32. LongFile o^perations are no longer available in Turbo 4.0.}
    end;
  end;

begin
  cl(0); print('Name          Length    # Storage    SF   Size now  Date       Time      CRC');
  cl(4); print('------------  --------  ----------  ----  --------  ---------  ------    ----');
  assign(f,fn);
  reset(f,1); done:=false;
  while (longfilepos(f)+27.0<longfilesize(f)) and not (abort or done) do
{! 33. Lo^ngFile operations are no longer available in Turbo 4.0.}
    pfn;
  close(f);
end;

  procedure lbrl(fn:astr; var abort:boolean);
var f:file;
    c,n,n1:integer;
    x:record
        st:byte;
        name:array[1..8] of char;
        ext:array[1..3] of char;
        index,len:integer;
        fil:array[1..16] of byte;
      end;
    next:boolean;
    i,i1:astr;

begin
  assign(f,fn);
  reset(f,32);
  blockread(f,x,1);
  c:=x.len*4-1;
  for n:=1 to c do begin
    blockread(f,x,1); i:='';
    if (x.st=0) and not abort then begin
      for n1:=1 to 8 do i:=i+x.name[n1];
      i:=i+'.';
      for n1:=1 to 3 do i:=i+x.ext[n1];
      i:=align(i)+' ';
      i1:=cstrr(x.len*128.0,10);
      while length(i1)<7 do i1:=' '+i1;
      i:=i+i1;
      printacr(i,abort,next);
    end;
  end;
  close(f);
end;

  procedure remove;
var pl,c,rn:integer; f:ulfrec; fn:astr; ff:file; u:userrec; tf:boolean; ch:char;
begin
  print('Enter filename to remove.'); prt(': '); mpl(12);
  input(fn,12);
  if fn<>'' then begin
    recno(fn,pl,rn); ch:=' ';
    while (rn<>0) and (not hangup) and (ch<>'Q') do begin
      seek(ulff,rn); read(ulff,f);
      if (usernum=f.owner) or dcs then begin
        nl; nl;
        print('Filename    : "'+f.filename+'"');
        print('Description : '+f.description);
        print('# of blocks : '+cstr(f.blocks));
        reset(uf); seek(uf,f.owner); read(uf,u); close(uf);
        print('U/L''d by    : '+u.name+' #'+cstr(f.owner));
        print('Downloaded  : '+cstr(f.nacc)+' times');
        nl;
        ynq('Delete this (Y/N/Q) ? ');
        cl(3); onek(ch,'QYN');
        if ch='Y' then begin
          DELETEFF(rn,pl);
          lrn:=lrn-1;
          sysoplog('Deleted "'+f.filename+'"');
          if dcs then begin
            ynq('Erase file too? ');
            tf:=yn;
          end else tf:=true;
          if tf then begin
            assign(ff,uboards[FILEBOARD].dlpath+f.filename);
            {$I-} erase(ff); {$I+}
            c:=ioresult;
          end;
        end;
      end;
      nrecno(fn,pl,rn);
    end;
    close(ulff);
  end;
  nl; nl;
end;

  procedure move;
var x,pl,c,rn,int,dbn:integer; f,f1:ulfrec; fn:astr; ff:file; i:astr;
    abort,next:boolean; fl:astr;
begin
  print('Enter filename to move.'); prt(': '); mpl(12);
  input(fn,12);
  if fn<>'' then begin
    recno(fn,pl,rn);
    if rn<>0 then begin
      seek(ulff,rn); read(ulff,f);
      abort:=false; nl; pfn(f,abort,next); nl; nl;
      ynq('Move this? ');
      if yn then begin
        nl;
        for int:=0 to maxulb do
          print(cstr(int)+' : '+uboards[int].name);
        nl; nl;
        prompt('To which directory? '); input(i,3);
        dbn:=value(i); if (dbn=0) and (i<>'0') then dbn:=-1;
        if (dbn<0) or (dbn>maxulb) then print('Can''t move it there.')
        else begin
          print('Moving file ...');
          fl:=uboards[FILEBOARD].dlpath+f.filename;
          copyfile(fl,uboards[dbn].dlpath+f.filename);
          assign(ff,fl);
          {$I-} erase(ff); {$I+}
          deleteff(rn,pl);
          close(ulff);
          int:=FILEBOARD; FILEBOARD:=dbn; fiscan(pl);
          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);
          f.blocks:=pl+1;
          seek(ulff,0); write(ulff,f);
          FILEBOARD:=int;
          sysoplog('Moved "'+f.filename+'"');
        end;
      end;
    end;
    close(ulff);
  end;
end;

procedure editfiles;
var u:userrec;
   pl,rn,int,dbn,x:integer; f,f1:ulfrec; fn,fd,lm,s:astr; ff:file; i:astr;
   fuku:integer; d:char; abort:boolean;
begin
  print('Enter filename to edit'); prt(': '); mpl(12); abort:=false;
  input(fn,12); nl; nl;
  recno(fn,pl,rn);
  if (fn<>'') and (pos('.',fn)<>0) and (rn<>0) then begin
  while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin
    seek(ulff,rn); read(ulff,f);
    reset(uf); seek(uf,f.owner); read(uf,u);
    if rn<>0 then begin
      repeat
        reset(uf); seek(uf,f.owner); read(uf,u);
        abort:=false;
        nl; printacr(#3+#5+'File Editor',abort,next); nl;
        printacr('<1> File name   : '+f.filename,abort,next);
        printacr('<2> Description : '+f.description,abort,next);
        printacr('<3> File points : '+cstr(f.filepoints),abort,next);
        printacr('<4> Uploaded By : '+u.name+' #'+cstr(f.owner),abort,next);
        printacr('<5> Change uploader''s file points',abort,next);
        printacr('<6> Make file a request file',abort,next);
        printacr('<Q> Quit <SpaceBar> Next',abort,next);
        nl;
        abort:=false;
        prt('Enter # (1-6,Q) : ');
        onek(c,'123456Q ');
        case c of
          '1':begin
                print('Enter new file name');
                prt(':');mpl(12);input(fn,12);
                if fn<>'' then begin
                if exist(uboards[FILEBOARD].dlpath+fn) then print('Can''t use that filename.') else begin
                  assign(ff,uboards[FILEBOARD].dlpath+f.filename);
                  {$I-} rename(ff,uboards[FILEBOARD].dlpath+fn); {$I+} x:=ioresult;
                  f.filename:=align(fn);
                end;
                end;
             end;
          '2':begin
                print('Enter new description');
                prt(':');mpl(60);inputl(s,60); if s<>'' then f.description:=s;
              end;
          '3':begin
                print('Enter new amount of file points');
                prt(':'); mpl(5); input(s,5); if s<>'' then f.filepoints:=value(s);
              end;
          '4':begin
                Print(u.name+' uploaded this file.');
                Print('Enter Name or # of user who uploaded it.');
                prt(':'); finduser(fuku); if fuku=0 then print('This user does not exist.');
                if fuku<>0 then f.owner:=fuku;
              end;
           '5':begin
                 nl;
                 print('<1> Take file points');
                 print('<2> Give file points');
                 nl; prt('Enter # (1,2) : ');
                 onek(d,'12');
                 case d of
                   '1':begin
                         prompt('How many file points to take away [Current: '+cstr(u.filepoints)+'] :');
                         input(s,5); u.filepoints:=u.filepoints-value(s);
                       end;
                   '2':begin
                         prompt('How many file points to add [Current: '+cstr(u.filepoints)+'] : ');
                         input(s,5); u.filepoints:=u.filepoints+value(s);
                       end;
                     end;
                 reset(uf); seek(uf,f.owner); write(uf,u);
                 if f.owner=usernum then thisuser:=u;{user}
               end;
           '6':begin
                 ynq('Make a request file? '); if yn then f.filepoints:=-1 else f.filepoints:=0;
               end;
            end;
          until (c=' ') or (c='Q') or (hangup);
          if c='Q' then abort:=true;
                   seek(ulff,rn); write(ulff,f);
    end;
    nrecno(fn,pl,rn);
  end;
           close(uf);
         close(ulff);
  end;
end;

procedure setdirs;
var i:astr; c1,c2:integer; done:boolean;

  procedure listit;
  var c:integer; abort,next:boolean; i:astr;
  begin
    nl; prompt('Dir''s to scan marked with "');cl(8);prompt('*');cl(1);print('"'); nl;
    if dcs then c:=0 else c:=1;
    abort:=false;
    while (c<=maxulb) and (not abort) and (not hangup) do begin
      if c in thisuser.dlnscn then
        i:=#3+#8+'* '
      else
        i:='  ';
      if c<10 then i:=i+' ';
      i:=i+#3+#3+cstr(c)+#3+#4+'. '+#3+#1+uboards[c].name;
      if (thisuser.dsl>=uboards[c].dsl) then printacr(i,abort,next);
      c:=c+1;
    end;
    nl;
  end;

begin
  listit; done:=false;
  repeat
    nl; prt('Enter number, Q, ? : ');
    input(i,3);
    if i='Q' then done:=true;
    if i='?' then listit;
    c1:=value(i);
    if not (i[1] in ['0'..'9']) then c1:=-1;
    if (c1<0) or ((c1<1) and (not dcs)) then c1:=-1;
    if (c1>maxulb) then c1:=-1;
    if c1<>-1 then
      if thisuser.dsl>=uboards[c1].dsl then begin
        nl;
        if c1 in thisuser.dlnscn then begin
          print(uboards[c1].name+' will NOT be scanned.');
          thisuser.dlnscn:=thisuser.dlnscn-[c1];
        end else begin
          print(uboards[c1].name+' WILL be scanned.');
          thisuser.dlnscn:=thisuser.dlnscn+[c1];
        end;
      end;
  until done or hangup;
end;

procedure pointdate;
var i:astr; n:integer;
begin
  nl; nl; nl;
  print('Enter limiting date for new files -');
  print('Date is currently set to '+ldat);
  print(' mm/dd/yy');
  prt(':'); mpl(8); input(i,8);
  nl; nl;
  n:=daynum(i);
  if n=0 then
    print('Illegal date.')
  else
    ldat:=i;
  nl; print('Current limiting date is '+ldat);
end;

procedure listboards(z:astr);
var b:integer; i:astr; abort,next:boolean; c:char; fuku:integer;
begin
  if z='' then c:=' ' else c:=z[1];
  nl;nl; print('Directories available to you:'); nl; nl;
  if dcs then b:=0 else b:=1; abort:=false;
  if c='' then c:=' ';
  dumb2:=c; fuku:=0;
  while (b<=maxulb) and (not abort) and (not hangup) do begin
    if (uboards[b].dsl<=thisuser.dsl) and (thisuser.age>=uboards[b].agereq)
    and (uboards[b].ar='@') and (uboards[b].key=c)
    or (uboards[b].ar in thisuser.ar) then begin
      if b<10 then i:=i+' ';
      i:=i+#3+#3+cstr(b);
      i:=i+' '#3+#1+'- '+#3+#0+uboards[b].name;
      fuku:=fuku+1; if fuku=2 then begin fuku:=0; printacr(i,abort,next); i:=''; end else
      if fuku=1 then i:=mln(i,46);
    end;
    b:=b+1;
  end;
  nl;nl;
end;

procedure dlbatch;
var ch:char; n:integer; hua,done:boolean; dok,abort,next:boolean; i:astr; fi:file of byte;

  function info(n:integer):astr;
  var i,i1:astr;
  begin
    i:=cstr(n)+'. '; if length(i)=3 then i:=' '+i;
    i:=i+stripname(ymbary[n].fn);
    while length(i)<20 do i:=i+' ';
    i:=i+ctim(ymbary[n].tt);
    info:=i;
  end;

var nfn:astr; t:integer;
begin
  done:=false;
  if ymodemfiles=0 then
    print('Batch queue empty.')
  else
    repeat
      nl;
      prt('Ymodem/Zmodem Batch: Q,L,D,R,C,? : ');
      onek(ch,'QLDRC?');
      case ch of
        'Q':done:=true;
        '?':begin
              print('Q:uit to D/L Menu   L:ist files in queue');
              print('D:ownload queue     R:emove file from queue');
              print('C:lear queue');
            end;
        'R':begin
              prt('Number to remove (1-'+cstr(ymodemfiles)+') ? ');
              input(i,2); n:=value(i);
              if (n>0) and (n<=ymodemfiles) then begin
                ymbdel(n);
                print('Deleted out of queue.');
              end;
              if ymodemfiles=0 then begin
                done:=true;
                print('Queue empty.');
              end;
            end;
        'D':if incom and (ymodemfiles>0) then begin
              nl; nl; ynq('Hang up after transfer? '); hua:=yn;
              nl; prt('Download 1) Ymodem 2) Zmodem :');
              onek(c,'12'); if c='1' then ymodem:=true;
              if c='2' then ymodem:=false;
              ucrc:=true;
              nl; nl; print('Transmitting batch - Files: '+cstr(ymodemfiles)+
                            '  Time: '+ctim(ymbtt));
              nl;
              repeat
                if nsl>=ymbary[1].tt then begin
                  if ymodem then
                  send(ymbary[1].fn,dok,true,rte)
                     else begin
                       nfn:='';
                       for t:=1 to length(ymbary[1].fn) do
                         if ymbary[1].fn[t]<>' ' then nfn:=nfn+ymbary[1].fn[t];
                       exec('\command.com','/c del '+nfn);
                       exec('\command.com','/c dsz sz '+nfn);
                     end;
                  if dok then
                    sysoplog('Downloaded (Batch) "'+stripname(ymbary[1].fn)+'"')
                  else
                    sysoplog('Tried D/L "'+stripname(ymbary[1].fn)+'"');
                end;
                ymbdel(1);
              until (not dok) or hangup or (ymodemfiles<1);
              if dok then
                endbatch;
              done:=true;
              if hua then hangup:=true;
            end;
        'L':begin
              abort:=false; n:=1;
              while (not abort) and (not hangup) and (n<=ymodemfiles) do begin
                printacr(info(n),abort,next);
                n:=n+1;
              end;
            end;
        'C':begin
              ynq('Clear queue? ');
              if yn then begin
                ymodemfiles:=0;
                ymbtt:=0.0;
                done:=true;
              end;
            end;
      end;
    until done or hangup;
end;