home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / ZCPR33 / A-R / FOR-SUPP.LBR / CLEANFOR.PZS / CLEANFOR.PAS
Pascal/Delphi Source File  |  2000-06-30  |  11KB  |  390 lines
  1. program CleanFOR;            { Cleans up FOR. files }
  2.                              { compiles with ending address of $A400 }
  3. const
  4.   debug = false;
  5.   version = '1.0';
  6.   date    = '05 Aug 87';
  7.   authors = 'C. Wilson';
  8.  
  9.   BufSize  = 1800;   { Max. size of buffer for FOR names  }
  10.  
  11.   User   = 32;       { CP/M function numbers }
  12.   DefDrv = 25;
  13.   SelDsk = 14;
  14.   Res    = 13;
  15.  
  16.   { values patchable with DDT, starting at 2100 hex: }
  17.  
  18.   FORLabel  : array[1..9] of char = '[[CONFIG>';           { pointer }
  19.   FORdrv    : char = 'A';
  20.   FORusr    : byte =  14;
  21.   SrchLabel : array[1..8] of char = '[DRIVES>';   { pointer }
  22.   ListLen   : byte = 5;            { length of drive list }
  23.   DriveLst  : array[1..16] of char = 'ABCDE'^@^@^@^@^@^@^@^@^@^@^@;
  24.  
  25.   SpecLength = 12;
  26.  
  27. type
  28.   SpecType = string[SpecLength];
  29.   BufType  = array[1..11] of string[76];
  30.   SpecBuf  = array[1..BufSize] of SpecType;
  31.  
  32. var
  33.   FORBuf     : SpecBuf;
  34.   Match      : array[1..BufSize] of boolean;
  35.   Buffer     : BufType;
  36.  
  37.   NEWFile,
  38.   FORFile,
  39.   FORFil2   : text;
  40.  
  41.   UnTypedFil  : file;
  42.  
  43.   Total,
  44.   Unmatched,
  45.   DiskBlock,
  46.   FilsDone,
  47.   Desc,
  48.   DefDrvVal,
  49.   DefUsr     : integer;
  50.  
  51.   line,
  52.   MatchUsr,
  53.   SrchDrv       : byte;
  54.  
  55.   SearchSpec : SpecType;
  56.  
  57.   BufFull,
  58.   AllMatch,
  59.   AllDone    : boolean;
  60.  
  61.  
  62. function Exist(Spec : SpecType) : boolean;
  63.   { Searches for standard Turbo filespec at current user, current
  64.     drive, or on alternate drive if included in the filespec   }
  65.   var
  66.     fil      : file;
  67.   begin
  68.   assign(fil, Spec);
  69.   {$I-} reset(fil) {$I+} ;
  70.   exist := (IOresult = 0);
  71.   close(fil);
  72.   end;     { of procedure Exist }
  73.  
  74.  
  75. function Search(SearchName : SpecType) : boolean;
  76.            { Detects match on current drive, all users }
  77.   const
  78.     DMA    = $80;       { default address }
  79.  
  80.     SetDMA    = 26;     { CP/M function numbers }
  81.     FindFirst = 17;
  82.     FindNext  = 18;
  83.   type
  84.     FileRec = record               { adapted from P.D. DIR.PAS }
  85.       case boolean of
  86.         true:
  87.          (drv : byte;
  88.           FName  : array[1..11] of char;
  89.           extent, s1, s2, RecCount : byte;
  90.           dn : array[16..31] of byte);
  91.         false:
  92.          (init : array[1..32] of byte);
  93.         end;
  94.   var
  95.     found     : boolean;
  96.     off, Ch   : integer;
  97.     SearchBlk : FileRec;
  98.     AnswerBlk : array[0..3] of FileRec;
  99.  
  100.   begin
  101.   fillchar(SearchBlk.init,32,0);     { initialize search FCB }
  102.   SearchBlk.drv := ord('?');         { match all user areas & erased files }
  103.   for Ch := 1 to 11 do
  104.     SearchBlk.FName[Ch] := SearchName[Ch];    { fill in file name }
  105.   BDOS(SetDMA,addr(AnswerBlk));             { set DMA to our buffer }
  106.   off   := bdos(FindFirst,addr(SearchBlk));
  107.   found := false;
  108.   while (off <> 255) and (found = false) do
  109.     with AnswerBlk[off] do
  110.       begin
  111.       for Ch := 1 to 11 do
  112.         FName[Ch] := char(ord(FName[Ch]) and $7F);    { kill R/O, etc. flags }
  113.       if (drv <> $E5) and (FName = SearchBlk.Fname)
  114.         then
  115.           begin
  116.           found    := true;                           { else erased file }
  117.           MatchUsr := drv;
  118.           end;
  119.       off := bdos(FindNext,addr(SearchBlk));
  120.       end;
  121.   Search := found;
  122.   BDOS(SetDMA,DMA);  { restore default DMA }
  123.   if debug then
  124.     writeln('DEBUG: Search for ',searchname,' was ',found);
  125.   end;       { of procedure Search }
  126.  
  127.  
  128. function Yes : boolean;  { returns false if answer <> 'Y','y' }
  129.   var
  130.     response : char;
  131.   begin
  132.   write(' (Y/N)? N',^H);
  133.   read(kbd,response);
  134.   response := upcase(response);
  135.   write(response);
  136.   if response = 'Y' then Yes := true
  137.   else Yes := false;
  138.   end;                  { of function Yes }
  139.  
  140.  
  141. procedure Parse(var arg : SpecType);
  142.           { Parses the first word of a capitalized string of up to 12
  143.             characters into CP/M FCB's filespec format.  NO DRIVESPEC
  144.             ALLOWED, but accepts a period as delimiter between filename
  145.             and type.      }
  146.   var
  147.     name : string[8];
  148.     tail : string[3];
  149.     lett,
  150.     DotPos,
  151.     SpcPos : integer;
  152.   begin
  153.   SpcPos := pos(' ', arg);
  154.   if SpcPos <> 0 then
  155.     arg := copy(arg, 1, SpcPos - 1);        { kill trailing spaces }
  156.   DotPos := pos('.', arg);
  157.   if DotPos <> 0 then                         { file type detected }
  158.     begin
  159.     tail := copy(arg, DotPos + 1, 255);      { all after  '.' }
  160.     name := copy(arg, 1, DotPos - 1);        { all before '.' }
  161.     for lett := DotPos to 8 do
  162.       name := name + ' ';                     { pad }
  163.     for lett := length(tail) to 3 do
  164.       tail := tail + ' ';
  165.     arg := name + tail;
  166.     end
  167.   else arg := copy(arg, 1, 8);             { chars 1-8 only }
  168.   end;               { of procedure Parse }
  169.  
  170.  
  171. procedure GoToDef;          { set to default drive/user }
  172.   begin
  173.   BDOS(SelDsk, DefDrvVal);
  174.   BDOS(User, DefUsr);
  175.   end;
  176.  
  177.  
  178. procedure GoToFOR;           { set to FOR drive/user     }
  179.   begin
  180.   BDOS(SelDsk, ord(FORDrv) - ord('A'));
  181.   BDOS(User, FORUsr);
  182.   end;
  183.  
  184.  
  185. procedure Finish;
  186.   begin
  187.   GoToDef;
  188.   writeln;
  189.   writeln(^I'Done.');
  190.   halt;
  191.   end;
  192.  
  193.  
  194. {$I CPMSTATS.INC }
  195.  
  196. function KSize(FilSiz : integer) : integer;
  197.          { convert Turbo filesize to Kb's, using block size DiskBlock }
  198.   var
  199.     size,  { in records or blocks }
  200.     extra : integer;
  201.   begin
  202.   size := FilSiz div 8;
  203.   if FilSiz mod 8 > 0 then size := size + 1;
  204.   extra := size mod DiskBlock;
  205.   if extra > 0 then size := size + (DiskBlock - extra);
  206.   KSize := size;
  207.   end;              { of function KSize }
  208.  
  209.  
  210. BEGIN                   (* MAIN PROGRAM *)
  211.  
  212. writeln;
  213. writeln('CLEANFOR ',version,' (c) ',date,' by ',authors,'.');
  214.  
  215. if ParamStr(1) = 'INSTALL' then
  216.   begin
  217.   assign(UntypedFil,'PDTINS.CHN');
  218.   Chain(UntypedFil);
  219.   end
  220. else if ParamCount <> 0 then   { display ZCPR-style help }
  221.   begin
  222.   writeln(^I,  'Removes unmatched entries from FOR. files.');
  223.   writeln('Usage:'^J^M^I'CLEANFOR');
  224.   halt;
  225.   end;
  226.  
  227. DefDrvVal := BDOS(DefDrv);    { get current drive }
  228. DefUsr    := BDOS(User,$FF);  {  "     "    user  }
  229. writeln;
  230. writeln(^I'Reset');
  231. BDOS(Res);                    { reset disk system }
  232. GoToFOR;                      { to FOR DU:        }
  233.  
  234. if not Exist('FOR') then
  235.   begin
  236.   write(^I^G,FORDrv, FORUsr, ':FOR. -- not found.  ABORT.');
  237.   Finish;
  238.   end
  239. else
  240.   begin
  241.   assign (FORFile,    'FOR');
  242.   reset  (FORFile);
  243.   assign (FORFil2,    'FOR');
  244.   reset  (FORFil2);
  245.   assign (UntypedFil, 'FOR');
  246.   reset  (UntypedFil);
  247.   end;
  248.  
  249. DiskBlock := CPMStats(FORDrv, size);         { get block size - 2k, 4k, etc. }
  250.  
  251. if CPMStats(FORDrv, space) < KSize(filesize(UnTypedFil))
  252. then                         { no room for FOR.NEW }
  253.   begin
  254.   close(FORFile);
  255.   close(FORFil2);
  256.   close(UntypedFil);
  257.   write(^I^G'Not enough room on drive ',FORDrv,':.  ABORT.');
  258.   Finish;
  259.   end
  260. else
  261.   begin
  262.   close(UntypedFil);
  263.   assign (NEWFile, 'FOR.NEW');
  264.   rewrite(NEWFile);
  265.   end;
  266.  
  267. AllMatch  := true;        { default to all FOR entries matched }
  268. Total     := 0;
  269. Unmatched := 0;
  270.  
  271. write(^I'Checking ', FORDrv, FORUsr, ':FOR. against drives -->');
  272. for SrchDrv := 1 to ListLen do write(' ', DriveLst[SrchDrv]);
  273. writeln('....');
  274. writeln;
  275.  
  276. WHILE NOT EOF(FORFile) DO        { loop to process FOR file }
  277.   begin
  278.   Desc := 1;
  279.  
  280.   while not (EOF(FORFile) or (Desc > BufSize)) do
  281.     begin                      { Fill buffer or read to EOF }
  282.     line := 1;
  283.     readln(FORFile,Buffer[line]);        { kill initial '----' }
  284.     readln(FORFile,FORBuf[Desc]);        { get file spec       }
  285.     repeat
  286.       line := succ(line);                { get end of this desc.}
  287.       readln(FORFile,Buffer[line]);
  288.     until (Buffer[line] = '   ') or (Buffer[line] = '') or EOF(FORFile);
  289.     Desc := succ(Desc);
  290.     end;
  291.  
  292.   FilsDone := Desc - 1;
  293.  
  294.   for Desc := 1 to FilsDone do
  295.     begin
  296.     Parse(FORBuf[Desc]);                 { to CP/M filespec }
  297.     Match[Desc] := false;                { no matches found yet }
  298.     end;
  299.  
  300.   AllDone := false;                { All entries not matched }
  301.  
  302.   for SrchDrv := 1 to ListLen do   { Search for matches on all drives in list }
  303.     if not AllDone then            { Quit searching when all entries matched }
  304.       begin
  305.       AllDone := true;
  306.       BDOS(SelDsk, ord(DriveLst[SrchDrv]) - ord('A'));
  307.       for Desc := 1 to FilsDone do          { go thru whole buffer }
  308.         if Match[Desc] = false then         { search only remaining unmatched }
  309.           begin
  310.           Match[Desc] := Search(FORBuf[Desc]);
  311.           if Match[Desc] then
  312.             begin
  313.             insert('.', ForBuf[Desc], 9);
  314.             write(FORBuf[Desc]);
  315.             lowvideo;
  316.             write(' matched on ');
  317.             normvideo;
  318.             writeln(DriveLst[SrchDrv],MatchUsr,':');
  319.             end;
  320.           end;
  321.       for Desc := 1 to FilsDone do
  322.         if Match[Desc] = false then AllDone := false;  { test for remaining }
  323.       end;
  324.  
  325.   GoToFOR;
  326.  
  327.   for Desc := 1 to FilsDone do     { Copy matched entries to FOR.NEW }
  328.     begin
  329.     Total := succ(Total);
  330.     line := 1;
  331.     if Match[Desc] = true then     { copy this entry }
  332.       repeat
  333.         line := succ(line);
  334.         readln(FORFil2,  Buffer[line]);
  335.         writeln(NEWFile, Buffer[line]);
  336.       until (Buffer[line] = '   ') or
  337.             (Buffer[line] = '') or
  338.             EOF(FORFil2)
  339.     else                           { display this entry, and skip over it }
  340.       begin
  341.       Unmatched := succ(Unmatched);
  342.       writeln('Deleting:');
  343.       lowvideo;
  344.       repeat
  345.         readln(FORFil2, Buffer[line]);
  346.         writeln(Buffer[line]);
  347.       until (Buffer[line] = '   ') or
  348.             (Buffer[line] = '') or
  349.             EOF(FORFil2);
  350.       delay(1000);
  351.       normvideo;
  352.       AllMatch := false;
  353.       end;
  354.     end;
  355.  
  356. END;       { of WHILE NOT EOF }
  357.  
  358. close(FORFile);
  359. close(FORFil2);
  360. close(NEWFile);
  361.  
  362. writeln;
  363. writeln(^I,Total,' total entries in ',FORDrv, FORUsr,':FOR.');
  364.  
  365. if AllMatch then
  366.   begin
  367.   write(^I'All entries matched.');
  368.   erase(NEWFile);
  369.   end
  370. else
  371.   begin
  372.   writeln(^I,Total - UnMatched,' entries matched.');
  373.   writeln(^I,UnMatched,' entries deleted.');
  374.   writeln;
  375.   write(^I'Keep changes');
  376.   if Yes then
  377.     begin
  378.     if exist('FOR.BAK') then        { Remove previous FOR.BAKs, since    }
  379.       begin                         {  Turbo Rename will create new ones }
  380.       assign(UntypedFil,'FOR.BAK');
  381.       erase(UntypedFil);
  382.       end;
  383.     rename(FORFile,'FOR.BAK');
  384.     rename(NEWFile,'FOR');
  385.     end
  386.   else erase(NEWFile);
  387.   end;
  388. Finish;
  389. END.
  390.