home *** CD-ROM | disk | FTP | other *** search
/ Black Box 4 / BlackBox.cdr / fileutil / dircnt12.arj / DIRCOUNT.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1992-02-05  |  5.7 KB  |  261 lines
  1.  
  2. (*
  3.  * DirCount - Count file directory entries and insert headers with
  4.  *            file information.
  5.  *
  6.  * Written by Samuel H. Smith, 12-30-88
  7.  *
  8.  *)
  9.  
  10. const
  11.    version   = 'DirCount 1.2, 02-05-92';
  12.  
  13. var
  14.    console:    text;
  15.    ctlfd:      text;
  16.  
  17.    bbsname:    string;
  18.    dirfile:    string;
  19.    title:      string;
  20.    dirnum:     integer;
  21.  
  22.    ibuf:       array[1..20480] of byte;
  23.    obuf:       array[1..20480] of byte;
  24.    line:       string;
  25.    sizes:      longint;
  26.    tsizes:     longint;
  27.    files:      word;
  28.    tfiles:     word;
  29.  
  30.  
  31. (* --------------------------------------------------------- *)
  32. function itoa (n: longint): string;
  33. var
  34.    tstr:          string;
  35.  
  36. begin
  37.    str(n, tstr);
  38.    itoa := tstr;
  39. end;
  40.  
  41.  
  42. (* --------------------------------------------------------- *)
  43. function insert_commas(s: string): string;
  44. var
  45.    i: integer;
  46. begin
  47.    i := length(s);
  48.    while i > 3 do
  49.    begin
  50.       dec(i,3);
  51.       insert(',',s,i+1);
  52.    end;
  53.  
  54.    insert_commas := s;
  55. end;
  56.  
  57.  
  58. (* --------------------------------------------------------- *)
  59. function numtostr(n: longint; width: integer): string;
  60. var
  61.    s: string;
  62.    t: string;
  63.    p: integer;
  64. begin
  65.    str((n shr 10) / 1000:0:2,t);
  66.    s := insert_commas( copy(t,1,length(t)-3) ) +
  67.         copy(t,length(t)-2,3) + ' megs';
  68.  
  69.    if width = 0 then
  70.       while s[length(s)] = ' ' do
  71.          dec(s[0]);
  72.  
  73.    while length(s) < width do
  74.       s := ' ' + s;
  75.  
  76.    numtostr := s;
  77. end;
  78.  
  79.  
  80. (* --------------------------------------------------------- *)
  81. function isfile: boolean;
  82. begin
  83.    isfile := (length(line) > 35) and
  84.              (line[26] = '-')  and (line[29] = '-') and
  85.              (line[21] >= '0') and (line[21] <= '9') and
  86.              (line[24] >= '0') and (line[24] <= '9');
  87. end;
  88.  
  89.  
  90. (* --------------------------------------------------------- *)
  91. procedure count_files;
  92. var
  93.    size: longint;
  94.    err:  integer;
  95.    tmp:  string;
  96.    ifd:  text;
  97.  
  98. begin
  99.    files := 0;
  100.    sizes := 0;
  101.  
  102.    assign(ifd,dirfile);
  103.    {$i-} reset(ifd); {$i+}
  104.    if ioresult <> 0 then
  105.    begin
  106.       writeln(console,'Can''t open DIR file ',dirfile);
  107.       halt(99);
  108.    end;
  109.  
  110.    setTextBuf(ifd,ibuf);
  111.    write(console,'  Counting: ',dirfile,'':10,^M);
  112.  
  113.    while not eof(ifd) do
  114.    begin
  115.       readln(ifd,line);
  116.       if isfile then
  117.       begin
  118.          inc(files);
  119.          tmp := copy(line,13,9);
  120.          while tmp[1] = ' ' do
  121.             delete(tmp,1,1);
  122.          val(tmp,size,err);
  123.          sizes := sizes + size;
  124.       end;
  125.    end;
  126.  
  127.    close(ifd);
  128. end;
  129.  
  130.  
  131. (* --------------------------------------------------------- *)
  132. procedure update_dirfile;
  133. var
  134.    ifd:     text;
  135.    ofd:     text;
  136.    tmp:     string;
  137.  
  138. begin
  139.    assign(ifd,dirfile);
  140.    {$i-} reset(ifd); {$i+}
  141.    if ioresult <> 0 then
  142.    begin
  143.       writeln(console,'Can''t open DIR file ',dirfile);
  144.       halt(99);
  145.    end;
  146.  
  147.    assign(ofd,dirfile+'$');
  148.    {$i-} rewrite(ofd); {$i+}
  149.    if ioresult <> 0 then
  150.    begin
  151.       writeln(console,'Can''t create tempfile ',dirfile,'$');
  152.       halt(99);
  153.    end;
  154.  
  155.    setTextBuf(ifd,ibuf);
  156.    setTextBuf(ofd,obuf);
  157.    write(console,'Formatting: ',dirfile,'':10,^M);
  158.  
  159.    repeat
  160.       readln(ifd,line);
  161.    until isfile or eof(ifd);
  162.  
  163.    writeln(ofd);
  164.    writeln(ofd,'':38-length(bbsname) div 2,bbsname);
  165.    writeln(ofd);
  166.    writeln(ofd,'':38-length(title) div 2,title);
  167.  
  168.    tmp := itoa(files) + ' files using ' + numtostr(sizes,0) + ' megs';
  169.    writeln(ofd,'':38-length(tmp) div 2,tmp);
  170.  
  171.    writeln(ofd);
  172.    writeln(ofd,' File Name      Size     Date                  File Description');
  173.    writeln(ofd,'------------  -------  --------  ---------------------------------------------');
  174.    writeln(ofd);
  175.  
  176.    writeln(ofd,line);
  177.    while not eof(ifd) do
  178.    begin
  179.       readln(ifd,line);
  180.       writeln(ofd,line);
  181.    end;
  182.  
  183.    close(ofd);
  184.    close(ifd);
  185.  
  186.    {$i-} erase(ifd); {$i+}
  187.    if ioresult <> 0 then
  188.    begin
  189.       writeln(console,'Can''t erase old dirfile ',dirfile);
  190.       halt(99);
  191.    end;
  192.  
  193.    {$i-} rename(ofd,dirfile); {$i+}
  194.    if ioresult <> 0 then
  195.    begin
  196.       writeln(console,'Can''t rename new dirfile ',dirfile,'$ to ',dirfile);
  197.       halt(99);
  198.    end;
  199.  
  200. end;
  201.  
  202.  
  203. (* --------------------------------------------------------- *)
  204. begin
  205.    assign(console,'CON');
  206.    rewrite(console);
  207.    writeln(console,version,';  Copyright 1988, 1991 Samuel H. Smith');
  208.    writeln(console);
  209.  
  210.    if paramcount <> 1 then
  211.    begin
  212.       writeln(console,'Usage:    DirCount configfile [>summary]');
  213.       writeln(console,'Example:  DirCount COUNT.CNF >\PCB\GEN\BLT16');
  214.       halt(99);
  215.    end;
  216.  
  217.    assign(ctlfd,paramstr(1));
  218.    {$i-} reset(ctlfd); {$i+}
  219.    if ioresult <> 0 then
  220.    begin
  221.       writeln(console,'Can''t open configuration file ',paramstr(1));
  222.       halt(99);
  223.    end;
  224.  
  225.    readln(ctlfd,bbsname);
  226.    dirnum := 0;
  227.    tfiles := 0;
  228.    tsizes := 0;
  229.  
  230.    writeln;
  231.    writeln('':38-length(bbsname) div 2,bbsname);
  232.    writeln;
  233.  
  234.    writeln(' Dir   Files      Bytes                       Description');
  235.    writeln('----- ------- --------------  ----------------------------------------------');
  236.  
  237.    while not eof(ctlfd) do
  238.    begin
  239.       readln(ctlfd,dirfile);
  240.       readln(ctlfd,title);
  241.       inc(dirnum);
  242.  
  243.       count_files;
  244.  
  245.       writeln(insert_commas( itoa(dirnum)):4,
  246.               insert_commas( itoa(files)):8,
  247.               numtostr(sizes,15),'    ',title);
  248.       tfiles := tfiles + files;
  249.       tsizes := tsizes + sizes;
  250.  
  251.       update_dirfile;
  252.    end;
  253.  
  254.    write(console,'':60,^M);
  255.    close(ctlfd);
  256.  
  257.    writeln('      ======= ================');
  258.    writeln(insert_commas( itoa(tfiles) ):12,numtostr(tsizes,15));
  259. end.
  260.  
  261.