* new tool

compiler/utils/fixlog.pp

@@ -0,0 +1,119 @@
+{
+    $Id$
+    Copyright (c) 1999 by Peter Vreman
+
+    Remove all revision logs from source files after 20 revisions
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+program fixlog;
+
+{$mode objfpc}
+{$H+}
+
+uses
+  sysutils;
+
+const
+  maxrevs = 20;
+  bufsize = 32*1024;
+
+procedure dofile(const fn:string);
+var
+  t,f : text;
+  s : string;
+  skip : boolean;
+  found,revs : integer;
+  fbuf,tbuf : pointer;
+begin
+  getmem(fbuf,bufsize);
+  getmem(tbuf,bufsize);
+  assign(t,fn);
+  assign(f,'fixlog.tmp');
+  {$I-}
+   reset(t);
+  {$I+}
+  if ioresult<>0 then
+   exit;
+  rewrite(f);
+  settextbuf(t,tbuf^,bufsize);
+  settextbuf(f,fbuf^,bufsize);
+  found:=0;
+  revs:=0;
+  skip:=false;
+  while not eof(t) do
+   begin
+     readln(t,s);
+     case found of
+      0 :
+        begin
+          if pos('$Log: ',s)>0 then
+           found:=1;
+          skip:=false;
+          writeln(f,s);
+        end;
+      1 :
+        begin
+          if pos('Revision',s)>0 then
+           begin
+             inc(revs);
+             if revs>maxrevs then
+              begin
+                skip:=true;
+                found:=2;
+              end;
+           end
+          else
+           if pos('}',s)>0 then
+            begin
+              skip:=false;
+              found:=0;
+            end;
+          if not skip then
+           writeln(f,s);
+        end;
+      2 :
+        begin
+          if pos('}',s)>0 then
+           begin
+             skip:=false;
+             found:=0;
+           end;
+          if not skip then
+           writeln(f,s);
+        end;
+     end;
+   end;
+  close(t);
+  close(f);
+  erase(t);
+  rename(f,fn);
+  freemem(tbuf);
+  freemem(fbuf);
+end;
+
+var
+  dir : tsearchrec;
+  i   : integer;
+begin
+  for i:=1to paramcount do
+   begin
+     if findfirst(paramstr(i),faAnyFile,dir)=0 then
+      repeat
+        dofile(dir.name);
+      until findnext(dir)<>0;
+     findclose(dir);
+   end;
+end.
+{
+  $Log$
+  Revision 1.1  1999-10-06 06:29:03  peter
+    * new tool
+
+}