home *** CD-ROM | disk | FTP | other *** search
/ Jason Aller Floppy Collection / 153.img / TELES.ZIP / DLP2.PAS < prev    next >
Pascal/Delphi Source File  |  1988-07-24  |  17KB  |  529 lines
  1. procedure arcl(fn:astr; var abort:boolean);
  2. type ei=record l,h:integer; end;
  3.      archead=record
  4.                name:array[1..13] of char;
  5.                size:ei;
  6.                date,time,crc:integer;
  7.                len:ei;
  8.              end;
  9. var f:file; b:byte;
  10.     head:archead;
  11.     done,next:boolean;
  12.  
  13.   function unsigned(i:integer):real;
  14.   begin
  15.     if i>=0 then
  16.       unsigned:=int(i)
  17.     else
  18.       unsigned:=65536.0+int(i);
  19.   end;
  20.  
  21.   function valueei(x:ei):real;
  22.   var rl:real;
  23.   begin
  24.     rl:=unsigned(x.h)*65536.0+unsigned(x.l);
  25.     if rl>=32768.0*65536.0 then
  26.       rl:=65536.0*65536.0-rl+1;
  27.     valueei:=rl;
  28.   end;
  29.  
  30.   function tw(n : integer):astr;
  31.     var s : string[2];
  32.     begin
  33.       s:=cstr(n);
  34.       while length(s)<2 do
  35.         s:='0'+s;
  36.       tw:=s;
  37.     end;
  38.  
  39.   function fourhex(n : integer):astr;
  40.     var h : integer;
  41.         i : integer;
  42.         he : astr;
  43.     const hexdigit : array [0..15] of char = '0123456789ABCDEF';
  44.     begin
  45.       he:='';
  46.       for i := 1 to 4 do begin
  47.         h := (n shr 12) and $000F;
  48.         he:=he+hexdigit[h];
  49.         n := n shl 4
  50.       end;
  51.       fourhex:=he;
  52.     end;
  53.  
  54.   procedure pfn;
  55.   var i,i1:astr; try,press:byte; dy,mo,yr,hh,mm,ss:integer;
  56.   const mon : array [1..12] of string[3] =
  57.     ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
  58.       'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
  59.   begin
  60.     b:=0; try:=0;
  61.     while not eof(f) and (b<>26) and (try<5) do begin
  62.       blockread(f,b,1);
  63.       try:=try+1;
  64.     end;
  65.     if try>=5 then longseek(f,filesize(f)-2.0);
  66.     if longfilepos(f)+27<longfilesize(f) then begin
  67. {! 31. ^LongFile operations are no longer available in Turbo 4.0.}
  68.       blockread(f,press,1);
  69.       if press<>0 then begin
  70.           if press=1 then begin
  71.             blockread(f,head,sizeof(head)-sizeof(ei));
  72.             head.len:=head.size;
  73.             end
  74.         else
  75.             blockread(f,head,sizeof(head));
  76.         i:=''; b:=1;
  77.         while (head.name[b]<>#0) and (b<=13) do begin
  78.           i:=i+head.name[b];
  79.           b:=b+1;
  80.           end;
  81.         i:=align(i)+' ';
  82.         i1:=cstrr(valueei(head.len),10);
  83.         while length(i1)<9 do i1:=' '+i1;
  84.         i:=i+i1+'  ';
  85.  
  86.         case press of
  87.           1    : i:=i+'1  Stored ';
  88.           2    : i:=i+'2  Stored ';
  89.           3    : i:=i+'3  Packed ';
  90.           4    : i:=i+'4 Squeezed';
  91.           5    : i:=i+'5 crunched';
  92.           6    : i:=i+'6 Crunched';
  93.           7    : i:=i+'7 Crunched';
  94.           8    : i:=i+'8 Crunched';
  95.           9    : i:=i+'9 Squashed'
  96.         else begin
  97.                  i1:=cstr(press);
  98.                  while length(i1)<2 do
  99.                     i1:=i1+' ';
  100.                  i:=i+i1+' Unknown';
  101.                  end;
  102.             end;
  103.         i1:=cstr(100 - trunc(100.0 * valueei(head.size) / valueei(head.len)));
  104.         while length(i1)<5 do
  105.             i1:=' '+i1;
  106.         i:=i+i1+'%  ';
  107.         i1:=cstrr(valueei(head.size),10);
  108.         while length(i1)<8 do i1:=' '+i1;
  109.         i:=i+i1+'  ';
  110.  
  111.         yr:=(head.date shr 9)  and $7f;
  112.         mo:=(head.date shr 5)  and $0f;
  113.         dy:= head.date         and $1f;
  114.         hh:=(head.time shr 11) and $1f;
  115.         mm:=(head.time shr 5 ) and $3f;
  116.         ss:=(head.time         and $1f) * 2;
  117.  
  118.         i:=i+tw(dy)+' '+mon[mo]+' '+tw((yr+80) mod 100)+'  ';
  119.         i:=i+tw(hh)+':'+tw(mm)+':'+tw(ss)+'  ';
  120.         i:=i+fourhex(head.crc);
  121.  
  122.         printacr(i,abort,next);
  123.       end else done:=true;
  124.       longseek(f,longfilepos(f)+valueei(head.size));
  125. {! 32. LongFile o^perations are no longer available in Turbo 4.0.}
  126.     end;
  127.   end;
  128.  
  129. begin
  130.   cl(0); print('Name          Length    # Storage    SF   Size now  Date       Time      CRC');
  131.   cl(4); print('------------  --------  ----------  ----  --------  ---------  ------    ----');
  132.   assign(f,fn);
  133.   reset(f,1); done:=false;
  134.   while (longfilepos(f)+27.0<longfilesize(f)) and not (abort or done) do
  135. {! 33. Lo^ngFile operations are no longer available in Turbo 4.0.}
  136.     pfn;
  137.   close(f);
  138. end;
  139.  
  140.   procedure lbrl(fn:astr; var abort:boolean);
  141. var f:file;
  142.     c,n,n1:integer;
  143.     x:record
  144.         st:byte;
  145.         name:array[1..8] of char;
  146.         ext:array[1..3] of char;
  147.         index,len:integer;
  148.         fil:array[1..16] of byte;
  149.       end;
  150.     next:boolean;
  151.     i,i1:astr;
  152.  
  153. begin
  154.   assign(f,fn);
  155.   reset(f,32);
  156.   blockread(f,x,1);
  157.   c:=x.len*4-1;
  158.   for n:=1 to c do begin
  159.     blockread(f,x,1); i:='';
  160.     if (x.st=0) and not abort then begin
  161.       for n1:=1 to 8 do i:=i+x.name[n1];
  162.       i:=i+'.';
  163.       for n1:=1 to 3 do i:=i+x.ext[n1];
  164.       i:=align(i)+' ';
  165.       i1:=cstrr(x.len*128.0,10);
  166.       while length(i1)<7 do i1:=' '+i1;
  167.       i:=i+i1;
  168.       printacr(i,abort,next);
  169.     end;
  170.   end;
  171.   close(f);
  172. end;
  173.  
  174.   procedure remove;
  175. var pl,c,rn:integer; f:ulfrec; fn:astr; ff:file; u:userrec; tf:boolean; ch:char;
  176. begin
  177.   print('Enter filename to remove.'); prt(': '); mpl(12);
  178.   input(fn,12);
  179.   if fn<>'' then begin
  180.     recno(fn,pl,rn); ch:=' ';
  181.     while (rn<>0) and (not hangup) and (ch<>'Q') do begin
  182.       seek(ulff,rn); read(ulff,f);
  183.       if (usernum=f.owner) or dcs then begin
  184.         nl; nl;
  185.         print('Filename    : "'+f.filename+'"');
  186.         print('Description : '+f.description);
  187.         print('# of blocks : '+cstr(f.blocks));
  188.         reset(uf); seek(uf,f.owner); read(uf,u); close(uf);
  189.         print('U/L''d by    : '+u.name+' #'+cstr(f.owner));
  190.         print('Downloaded  : '+cstr(f.nacc)+' times');
  191.         nl;
  192.         ynq('Delete this (Y/N/Q) ? ');
  193.         cl(3); onek(ch,'QYN');
  194.         if ch='Y' then begin
  195.           DELETEFF(rn,pl);
  196.           lrn:=lrn-1;
  197.           sysoplog('Deleted "'+f.filename+'"');
  198.           if dcs then begin
  199.             ynq('Erase file too? ');
  200.             tf:=yn;
  201.           end else tf:=true;
  202.           if tf then begin
  203.             assign(ff,uboards[FILEBOARD].dlpath+f.filename);
  204.             {$I-} erase(ff); {$I+}
  205.             c:=ioresult;
  206.           end;
  207.         end;
  208.       end;
  209.       nrecno(fn,pl,rn);
  210.     end;
  211.     close(ulff);
  212.   end;
  213.   nl; nl;
  214. end;
  215.  
  216.   procedure move;
  217. var x,pl,c,rn,int,dbn:integer; f,f1:ulfrec; fn:astr; ff:file; i:astr;
  218.     abort,next:boolean; fl:astr;
  219. begin
  220.   print('Enter filename to move.'); prt(': '); mpl(12);
  221.   input(fn,12);
  222.   if fn<>'' then begin
  223.     recno(fn,pl,rn);
  224.     if rn<>0 then begin
  225.       seek(ulff,rn); read(ulff,f);
  226.       abort:=false; nl; pfn(f,abort,next); nl; nl;
  227.       ynq('Move this? ');
  228.       if yn then begin
  229.         nl;
  230.         for int:=0 to maxulb do
  231.           print(cstr(int)+' : '+uboards[int].name);
  232.         nl; nl;
  233.         prompt('To which directory? '); input(i,3);
  234.         dbn:=value(i); if (dbn=0) and (i<>'0') then dbn:=-1;
  235.         if (dbn<0) or (dbn>maxulb) then print('Can''t move it there.')
  236.         else begin
  237.           print('Moving file ...');
  238.           fl:=uboards[FILEBOARD].dlpath+f.filename;
  239.           copyfile(fl,uboards[dbn].dlpath+f.filename);
  240.           assign(ff,fl);
  241.           {$I-} erase(ff); {$I+}
  242.           deleteff(rn,pl);
  243.           close(ulff);
  244.           int:=FILEBOARD; FILEBOARD:=dbn; fiscan(pl);
  245.           for x:=pl downto 1 do begin
  246.             seek(ulff,x); read(ulff,f1);
  247.             seek(ulff,x+1); write(ulff,f1);
  248.           end;
  249.           seek(ulff,1);
  250.           write(ulff,f);
  251.           f.blocks:=pl+1;
  252.           seek(ulff,0); write(ulff,f);
  253.           FILEBOARD:=int;
  254.           sysoplog('Moved "'+f.filename+'"');
  255.         end;
  256.       end;
  257.     end;
  258.     close(ulff);
  259.   end;
  260. end;
  261.  
  262. procedure editfiles;
  263. var u:userrec;
  264.    pl,rn,int,dbn,x:integer; f,f1:ulfrec; fn,fd,lm,s:astr; ff:file; i:astr;
  265.    fuku:integer; d:char; abort:boolean;
  266. begin
  267.   print('Enter filename to edit'); prt(': '); mpl(12); abort:=false;
  268.   input(fn,12); nl; nl;
  269.   recno(fn,pl,rn);
  270.   if (fn<>'') and (pos('.',fn)<>0) and (rn<>0) then begin
  271.   while (fn<>'') and (rn<>0) and (not abort) and (not hangup) do begin
  272.     seek(ulff,rn); read(ulff,f);
  273.     reset(uf); seek(uf,f.owner); read(uf,u);
  274.     if rn<>0 then begin
  275.       repeat
  276.         reset(uf); seek(uf,f.owner); read(uf,u);
  277.         abort:=false;
  278.         nl; printacr(#3+#5+'File Editor',abort,next); nl;
  279.         printacr('<1> File name   : '+f.filename,abort,next);
  280.         printacr('<2> Description : '+f.description,abort,next);
  281.         printacr('<3> File points : '+cstr(f.filepoints),abort,next);
  282.         printacr('<4> Uploaded By : '+u.name+' #'+cstr(f.owner),abort,next);
  283.         printacr('<5> Change uploader''s file points',abort,next);
  284.         printacr('<6> Make file a request file',abort,next);
  285.         printacr('<Q> Quit <SpaceBar> Next',abort,next);
  286.         nl;
  287.         abort:=false;
  288.         prt('Enter # (1-6,Q) : ');
  289.         onek(c,'123456Q ');
  290.         case c of
  291.           '1':begin
  292.                 print('Enter new file name');
  293.                 prt(':');mpl(12);input(fn,12);
  294.                 if fn<>'' then begin
  295.                 if exist(uboards[FILEBOARD].dlpath+fn) then print('Can''t use that filename.') else begin
  296.                   assign(ff,uboards[FILEBOARD].dlpath+f.filename);
  297.                   {$I-} rename(ff,uboards[FILEBOARD].dlpath+fn); {$I+} x:=ioresult;
  298.                   f.filename:=align(fn);
  299.                 end;
  300.                 end;
  301.              end;
  302.           '2':begin
  303.                 print('Enter new description');
  304.                 prt(':');mpl(60);inputl(s,60); if s<>'' then f.description:=s;
  305.               end;
  306.           '3':begin
  307.                 print('Enter new amount of file points');
  308.                 prt(':'); mpl(5); input(s,5); if s<>'' then f.filepoints:=value(s);
  309.               end;
  310.           '4':begin
  311.                 Print(u.name+' uploaded this file.');
  312.                 Print('Enter Name or # of user who uploaded it.');
  313.                 prt(':'); finduser(fuku); if fuku=0 then print('This user does not exist.');
  314.                 if fuku<>0 then f.owner:=fuku;
  315.               end;
  316.            '5':begin
  317.                  nl;
  318.                  print('<1> Take file points');
  319.                  print('<2> Give file points');
  320.                  nl; prt('Enter # (1,2) : ');
  321.                  onek(d,'12');
  322.                  case d of
  323.                    '1':begin
  324.                          prompt('How many file points to take away [Current: '+cstr(u.filepoints)+'] :');
  325.                          input(s,5); u.filepoints:=u.filepoints-value(s);
  326.                        end;
  327.                    '2':begin
  328.                          prompt('How many file points to add [Current: '+cstr(u.filepoints)+'] : ');
  329.                          input(s,5); u.filepoints:=u.filepoints+value(s);
  330.                        end;
  331.                      end;
  332.                  reset(uf); seek(uf,f.owner); write(uf,u);
  333.                  if f.owner=usernum then thisuser:=u;{user}
  334.                end;
  335.            '6':begin
  336.                  ynq('Make a request file? '); if yn then f.filepoints:=-1 else f.filepoints:=0;
  337.                end;
  338.             end;
  339.           until (c=' ') or (c='Q') or (hangup);
  340.           if c='Q' then abort:=true;
  341.                    seek(ulff,rn); write(ulff,f);
  342.     end;
  343.     nrecno(fn,pl,rn);
  344.   end;
  345.            close(uf);
  346.          close(ulff);
  347.   end;
  348. end;
  349.  
  350. procedure setdirs;
  351. var i:astr; c1,c2:integer; done:boolean;
  352.  
  353.   procedure listit;
  354.   var c:integer; abort,next:boolean; i:astr;
  355.   begin
  356.     nl; prompt('Dir''s to scan marked with "');cl(8);prompt('*');cl(1);print('"'); nl;
  357.     if dcs then c:=0 else c:=1;
  358.     abort:=false;
  359.     while (c<=maxulb) and (not abort) and (not hangup) do begin
  360.       if c in thisuser.dlnscn then
  361.         i:=#3+#8+'* '
  362.       else
  363.         i:='  ';
  364.       if c<10 then i:=i+' ';
  365.       i:=i+#3+#3+cstr(c)+#3+#4+'. '+#3+#1+uboards[c].name;
  366.       if (thisuser.dsl>=uboards[c].dsl) then printacr(i,abort,next);
  367.       c:=c+1;
  368.     end;
  369.     nl;
  370.   end;
  371.  
  372. begin
  373.   listit; done:=false;
  374.   repeat
  375.     nl; prt('Enter number, Q, ? : ');
  376.     input(i,3);
  377.     if i='Q' then done:=true;
  378.     if i='?' then listit;
  379.     c1:=value(i);
  380.     if not (i[1] in ['0'..'9']) then c1:=-1;
  381.     if (c1<0) or ((c1<1) and (not dcs)) then c1:=-1;
  382.     if (c1>maxulb) then c1:=-1;
  383.     if c1<>-1 then
  384.       if thisuser.dsl>=uboards[c1].dsl then begin
  385.         nl;
  386.         if c1 in thisuser.dlnscn then begin
  387.           print(uboards[c1].name+' will NOT be scanned.');
  388.           thisuser.dlnscn:=thisuser.dlnscn-[c1];
  389.         end else begin
  390.           print(uboards[c1].name+' WILL be scanned.');
  391.           thisuser.dlnscn:=thisuser.dlnscn+[c1];
  392.         end;
  393.       end;
  394.   until done or hangup;
  395. end;
  396.  
  397. procedure pointdate;
  398. var i:astr; n:integer;
  399. begin
  400.   nl; nl; nl;
  401.   print('Enter limiting date for new files -');
  402.   print('Date is currently set to '+ldat);
  403.   print(' mm/dd/yy');
  404.   prt(':'); mpl(8); input(i,8);
  405.   nl; nl;
  406.   n:=daynum(i);
  407.   if n=0 then
  408.     print('Illegal date.')
  409.   else
  410.     ldat:=i;
  411.   nl; print('Current limiting date is '+ldat);
  412. end;
  413.  
  414. procedure listboards(z:astr);
  415. var b:integer; i:astr; abort,next:boolean; c:char; fuku:integer;
  416. begin
  417.   if z='' then c:=' ' else c:=z[1];
  418.   nl;nl; print('Directories available to you:'); nl; nl;
  419.   if dcs then b:=0 else b:=1; abort:=false;
  420.   if c='' then c:=' ';
  421.   dumb2:=c; fuku:=0;
  422.   while (b<=maxulb) and (not abort) and (not hangup) do begin
  423.     if (uboards[b].dsl<=thisuser.dsl) and (thisuser.age>=uboards[b].agereq)
  424.     and (uboards[b].ar='@') and (uboards[b].key=c)
  425.     or (uboards[b].ar in thisuser.ar) then begin
  426.       if b<10 then i:=i+' ';
  427.       i:=i+#3+#3+cstr(b);
  428.       i:=i+' '#3+#1+'- '+#3+#0+uboards[b].name;
  429.       fuku:=fuku+1; if fuku=2 then begin fuku:=0; printacr(i,abort,next); i:=''; end else
  430.       if fuku=1 then i:=mln(i,46);
  431.     end;
  432.     b:=b+1;
  433.   end;
  434.   nl;nl;
  435. end;
  436.  
  437. procedure dlbatch;
  438. var ch:char; n:integer; hua,done:boolean; dok,abort,next:boolean; i:astr; fi:file of byte;
  439.  
  440.   function info(n:integer):astr;
  441.   var i,i1:astr;
  442.   begin
  443.     i:=cstr(n)+'. '; if length(i)=3 then i:=' '+i;
  444.     i:=i+stripname(ymbary[n].fn);
  445.     while length(i)<20 do i:=i+' ';
  446.     i:=i+ctim(ymbary[n].tt);
  447.     info:=i;
  448.   end;
  449.  
  450. var nfn:astr; t:integer;
  451. begin
  452.   done:=false;
  453.   if ymodemfiles=0 then
  454.     print('Batch queue empty.')
  455.   else
  456.     repeat
  457.       nl;
  458.       prt('Ymodem/Zmodem Batch: Q,L,D,R,C,? : ');
  459.       onek(ch,'QLDRC?');
  460.       case ch of
  461.         'Q':done:=true;
  462.         '?':begin
  463.               print('Q:uit to D/L Menu   L:ist files in queue');
  464.               print('D:ownload queue     R:emove file from queue');
  465.               print('C:lear queue');
  466.             end;
  467.         'R':begin
  468.               prt('Number to remove (1-'+cstr(ymodemfiles)+') ? ');
  469.               input(i,2); n:=value(i);
  470.               if (n>0) and (n<=ymodemfiles) then begin
  471.                 ymbdel(n);
  472.                 print('Deleted out of queue.');
  473.               end;
  474.               if ymodemfiles=0 then begin
  475.                 done:=true;
  476.                 print('Queue empty.');
  477.               end;
  478.             end;
  479.         'D':if incom and (ymodemfiles>0) then begin
  480.               nl; nl; ynq('Hang up after transfer? '); hua:=yn;
  481.               nl; prt('Download 1) Ymodem 2) Zmodem :');
  482.               onek(c,'12'); if c='1' then ymodem:=true;
  483.               if c='2' then ymodem:=false;
  484.               ucrc:=true;
  485.               nl; nl; print('Transmitting batch - Files: '+cstr(ymodemfiles)+
  486.                             '  Time: '+ctim(ymbtt));
  487.               nl;
  488.               repeat
  489.                 if nsl>=ymbary[1].tt then begin
  490.                   if ymodem then
  491.                   send(ymbary[1].fn,dok,true,rte)
  492.                      else begin
  493.                        nfn:='';
  494.                        for t:=1 to length(ymbary[1].fn) do
  495.                          if ymbary[1].fn[t]<>' ' then nfn:=nfn+ymbary[1].fn[t];
  496.                        exec('\command.com','/c del '+nfn);
  497.                        exec('\command.com','/c dsz sz '+nfn);
  498.                      end;
  499.                   if dok then
  500.                     sysoplog('Downloaded (Batch) "'+stripname(ymbary[1].fn)+'"')
  501.                   else
  502.                     sysoplog('Tried D/L "'+stripname(ymbary[1].fn)+'"');
  503.                 end;
  504.                 ymbdel(1);
  505.               until (not dok) or hangup or (ymodemfiles<1);
  506.               if dok then
  507.                 endbatch;
  508.               done:=true;
  509.               if hua then hangup:=true;
  510.             end;
  511.         'L':begin
  512.               abort:=false; n:=1;
  513.               while (not abort) and (not hangup) and (n<=ymodemfiles) do begin
  514.                 printacr(info(n),abort,next);
  515.                 n:=n+1;
  516.               end;
  517.             end;
  518.         'C':begin
  519.               ynq('Clear queue? ');
  520.               if yn then begin
  521.                 ymodemfiles:=0;
  522.                 ymbtt:=0.0;
  523.                 done:=true;
  524.               end;
  525.             end;
  526.       end;
  527.     until done or hangup;
  528. end;
  529.