1{ Search all lpk files, tell what lpl files are missing, too much or need change
2
3  Copyright (C) 2019 Mattias Gaertner mattias@freepascal.org
4
5  This library is free software; you can redistribute it and/or modify it
6  under the terms of the GNU Library General Public License as published by
7  the Free Software Foundation; either version 2 of the License, or (at your
8  option) any later version with the following modification:
9
10  As a special exception, the copyright holders of this library give you
11  permission to link this library with independent modules to produce an
12  executable, regardless of the license terms of these independent modules,and
13  to copy and distribute the resulting executable under terms of your choice,
14  provided that you also meet, for each linked independent module, the terms
15  and conditions of the license of that module. An independent module is a
16  module which is not derived from or based on this library. If you modify
17  this library, you may extend this exception to your version of the library,
18  but you are not obligated to do so. If you do not wish to do so, delete this
19  exception statement from your version.
20
21  This program is distributed in the hope that it will be useful, but WITHOUT
22  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
23  FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
24  for more details.
25
26  You should have received a copy of the GNU Library General Public License
27  along with this library; if not, write to the Free Software Foundation,
28  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
29}
30
31program lplupdate;
32
33{$mode objfpc}{$H+}
34
35uses
36  Classes, SysUtils, CustApp, contnrs,
37  FileProcs,
38  LazFileUtils, LazUTF8, Laz_XMLCfg;
39
40type
41
42  { TPackage }
43
44  TPackage = class
45  public
46    Filename: string;
47    Name: string;
48    Major: integer;
49    Minor: integer;
50    Release: integer;
51    Build: integer;
52    function VersionAsString: string;
53  end;
54
55  { TPackages }
56
57  TPackages = class(TObjectList)
58  private
59    function GetPackages(Index: integer): TPackage;
60  public
61    function IndexByName(PkgName: string): integer;
62    function FindByName(PkgName: string): TPackage;
63    property Packages[Index: integer]: TPackage read GetPackages; default;
64  end;
65
66  { TLink }
67
68  TLink = class
69  public
70    LPLFilename: string;
71    InLazarusDir: boolean; // true = PkgFilename starts with $(LazarusDir)
72    PkgName: string;
73    Major: integer;
74    Minor: integer;
75    Release: integer;
76    Build: integer;
77    PkgFilename: string; // can have macros
78    ExpFilename: string; // full PkgFilename without macros
79  end;
80
81  { TLinks }
82
83  TLinks = class(TObjectList)
84  private
85    function GetLinks(Index: integer): TLink;
86  public
87    function FindLinkWithName(PkgName: string): TLink;
88    property Links[Index: integer]: TLink read GetLinks; default;
89  end;
90
91  { TLPLUpdate }
92
93  TLPLUpdate = class(TCustomApplication)
94  private
95    FExecuteCommands: boolean;
96    FLazarusDir: string;
97    FLinksDir: string;
98    FPkgDir: string;
99    FQuiet: Boolean;
100    FVerbose: Boolean;
101    FWriteCommands: boolean;
102  protected
103    procedure DoRun; override;
104    procedure Error(Msg: string);
105    procedure ScanPackages(Dir: string; Packages: TPackages);
106    procedure ScanPackage(Filename: string; Packages: TPackages);
107    procedure ScanLinks(Dir: string; Links: TLinks);
108    procedure ScanLink(Filename: string; Links: TLinks);
109    procedure WriteMissingLinks(Packages: TPackages; Links: TLinks);
110    procedure WriteLinksWithWrongExpFilename(Packages: TPackages; Links: TLinks);
111    procedure WriteDeadLinks(Packages: TPackages; Links: TLinks);
112    procedure WriteLinksWithWrongVersion(Packages: TPackages; Links: TLinks);
113  public
114    constructor Create(TheOwner: TComponent); override;
115    destructor Destroy; override;
116    procedure WriteHelp; virtual;
117    function GetDefaultLazarusDir: string;
118    function GetLazarusDir: string;
119    function GetDefaultPkgDirectory: string;
120    function GetDefaultLinksDirectory: string;
121    property LazarusDir: string read FLazarusDir write FLazarusDir;
122    property PkgDir: string read FPkgDir write FPkgDir;
123    property LinksDir: string read FLinksDir write FLinksDir;
124    property Verbose: Boolean read FVerbose write FVerbose;
125    property Quiet: Boolean read FQuiet write FQuiet;
126    property WriteCommands: boolean read FWriteCommands write FWriteCommands;
127    property ExecuteCommands: boolean read FExecuteCommands write FExecuteCommands;
128  end;
129
130{ TLPLUpdate }
131
132procedure TLPLUpdate.DoRun;
133var
134  ErrorMsg: String;
135  Packages: TPackages;
136  Links: TLinks;
137begin
138  // quick check parameters
139  ErrorMsg:=CheckOptions('hvqlLpcx','help verbose quiet lazarusdir pkgdir linksdir commands');
140  if ErrorMsg<>'' then begin
141    Error(ErrorMsg);
142    Terminate;
143    Exit;
144  end;
145
146  // parse parameters
147  if HasOption('h','help') then begin
148    WriteHelp;
149    Terminate;
150    Exit;
151  end;
152
153  Verbose:=HasOption('v','verbose');
154  Quiet:=HasOption('q','quiet');
155
156  if HasOption('L','lazarusdir') then
157    LazarusDir:=CleanAndExpandDirectory(GetOptionValue('L','lazarusdir'))
158  else
159    LazarusDir:=GetDefaultLazarusDir;
160  if not DirectoryExistsUTF8(LazarusDir) then
161    Error('lazarus directory not found: '+LazarusDir);
162
163  if HasOption('p','pkgdir') then
164    PkgDir:=GetOptionValue('P','pkgdir')
165  else
166    PkgDir:=GetDefaultPkgDirectory;
167  if not DirectoryExistsUTF8(PkgDir) then
168    Error('package directory not found: '+PkgDir);
169
170  if HasOption('l','linksdir') then
171    LinksDir:=GetOptionValue('P','linksdir')
172  else
173    LinksDir:=GetDefaultLinksDirectory;
174  if not DirectoryExistsUTF8(LinksDir) then
175    Error('links directory not found: '+LinksDir);
176
177  WriteCommands:=HasOption('c','commands');
178  ExecuteCommands:=HasOption('x','execute');
179
180  if Verbose then begin
181    writeln('Info: LazarusDir=',LazarusDir);
182    writeln('Info: PkgDir=',PkgDir);
183    writeln('Info: LinksDir=',LinksDir);
184    writeln('Info: Show commands: ',WriteCommands);
185    writeln('Info: Execute commands: ',ExecuteCommands);
186  end;
187
188  if WriteCommands and ExecuteCommands then
189    Error('Either -c or -x, not both');
190
191  Packages:=TPackages.create(true);
192  Links:=TLinks.create(true);
193  try
194    ScanPackages(PkgDir,Packages);
195    ScanLinks(LinksDir,Links);
196
197    WriteMissingLinks(Packages,Links);
198    WriteLinksWithWrongExpFilename(Packages,Links);
199    WriteDeadLinks(Packages,Links);
200    WriteLinksWithWrongVersion(Packages,Links);
201
202  finally
203    Links.Free;
204    Packages.Free;
205  end;
206
207  // stop program loop
208  Terminate;
209end;
210
211procedure TLPLUpdate.Error(Msg: string);
212begin
213  ShowException(Exception.Create(Msg));
214end;
215
216procedure TLPLUpdate.ScanPackages(Dir: string; Packages: TPackages);
217var
218  FileInfo: TSearchRec;
219begin
220  if FindFirstUTF8(Dir+FileMask,faAnyFile,FileInfo)=0 then
221  begin
222    repeat
223      // skip special files
224      if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
225      then
226        continue;
227      if (FileInfo.Attr and faDirectory)>0 then begin
228        // scan sub directories too
229        ScanPackages(AppendPathDelim(Dir+FileInfo.Name),Packages);
230      end else if FilenameExtIs(FileInfo.Name,'lpk',true) then begin
231        ScanPackage(Dir+FileInfo.Name,Packages);
232      end;
233    until FindNextUTF8(FileInfo)<>0;
234  end;
235  FindCloseUTF8(FileInfo);
236end;
237
238procedure TLPLUpdate.ScanPackage(Filename: string; Packages: TPackages);
239var
240  XMLConfig: TXMLConfig;
241  Path: String;
242  Pkg: TPackage;
243begin
244  XMLConfig:=TXMLConfig.Create(Filename);
245  try
246    Pkg:=TPackage.Create;
247    Packages.Add(Pkg);
248    Pkg.Filename:=Filename;
249    Pkg.Name:=lowercase(ExtractFileNameOnly(Filename));
250    Path:='Package/Version/';
251    Pkg.Major:=XMLConfig.GetValue(Path+'Major',0);
252    Pkg.Minor:=XMLConfig.GetValue(Path+'Minor',0);
253    Pkg.Release:=XMLConfig.GetValue(Path+'Release',0);
254    Pkg.Build:=XMLConfig.GetValue(Path+'Build',0);
255    if Verbose then
256      writeln('TLPLUpdate.ScanPackage ',Pkg.Name,'-',Pkg.VersionAsString,' in ',CreateRelativePath(Pkg.Filename,PkgDir));
257  finally
258    XMLConfig.Free;
259  end;
260end;
261
262procedure TLPLUpdate.ScanLinks(Dir: string; Links: TLinks);
263var
264  FileInfo: TSearchRec;
265begin
266  if FindFirstUTF8(Dir+FileMask,faAnyFile,FileInfo)=0 then
267  begin
268    repeat
269      // skip special files
270      if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='')
271      then
272        continue;
273      if (FileInfo.Attr and faDirectory)>0 then begin
274        // skip
275      end else if FilenameExtIs(FileInfo.Name,'lpl',true) then begin
276        ScanLink(Dir+FileInfo.Name,Links);
277      end;
278    until FindNextUTF8(FileInfo)<>0;
279  end;
280  FindCloseUTF8(FileInfo);
281end;
282
283procedure TLPLUpdate.ScanLink(Filename: string; Links: TLinks);
284const
285  LazDirMacro = '$(LazarusDir)';
286var
287  Link: TLink;
288  s: String;
289  p: Integer;
290  Version: String;
291  i: LongInt;
292  v: LongInt;
293  sl: TStringList;
294begin
295  Link:=TLink.Create;
296  Links.Add(Link);
297  Link.LPLFilename:=Filename;
298  // for example: name-0.5.lpl
299  s:=ExtractFileNameOnly(Filename);
300  p:=Pos('-',s);
301  if p<1 then
302    Error('missing - in  lpl file name: '+Filename);
303  // package name
304  Link.PkgName:=copy(s,1,p-1);
305  if (Link.PkgName='') or (not IsValidIdent(Link.PkgName,true)) then
306    Error('invalid name in lpl file name: '+Filename);
307  // package version
308  Version:=copy(s,p+1,length(s));
309  i:=1;
310  repeat
311    p:=Pos('.',Version);
312    if p=1 then
313      Error('invalid version in lpl file name: '+Filename);
314    if p=0 then p:=length(s)+1;
315    v:=StrToIntDef(copy(Version,1,p-1),-1);
316    if v<0 then
317      Error('invalid version in lpl file name: '+Filename);
318    case i of
319    1: Link.Major:=v;
320    2: Link.Minor:=v;
321    3: Link.Release:=v;
322    4: Link.Build:=v;
323    end;
324    Version:=copy(Version,p+1,length(Version));
325    if Version='' then break;
326    inc(i);
327    if i>4 then
328      Error('invalid version in lpl file name: '+Filename)
329  until false;
330  // read file
331  sl:=TStringList.Create;
332  try
333    sl.LoadFromFile(Filename);
334    if sl.Count<1 then
335      Error('missing file name in lpl file: '+Filename);
336    Link.PkgFilename:=sl[0];
337    Link.ExpFilename:=Link.PkgFilename;
338    Link.InLazarusDir:=CompareText(copy(Link.PkgFilename,1,length(LazDirMacro)),LazDirMacro)=0;
339    if Link.InLazarusDir then
340      Link.ExpFilename:=LazarusDir+copy(Link.PkgFilename,length(LazDirMacro)+1,length(Link.PkgFilename));
341    Link.ExpFilename:=CleanAndExpandFilename(SetDirSeparators(Link.ExpFilename));
342  finally
343    sl.Free;
344  end;
345  if Verbose then
346    writeln('TLPLUpdate.ScanLink ',ExtractFileNameOnly(Filename),' in ',Link.PkgFilename);
347end;
348
349procedure TLPLUpdate.WriteMissingLinks(Packages: TPackages; Links: TLinks);
350// write packages which name is not in the links
351var
352  i: Integer;
353  Pkg: TPackage;
354  LPLFilename, Line: String;
355  sl: TStringList;
356begin
357  for i:=0 to Packages.Count-1 do begin
358    Pkg:=Packages[i];
359    if Links.FindLinkWithName(Pkg.Name)<>nil then continue;
360    if not (Quiet and WriteCommands) then
361      writeln('Missing link ',Pkg.Name+'-'+Pkg.VersionAsString,' in '+CreateRelativePath(Pkg.Filename,PkgDir));
362    LPLFilename:=CreateRelativePath(LinksDir,LazarusDir)+PathDelim+Pkg.Name+'-'+Pkg.VersionAsString+'.lpl';
363    Line:='$(LazarusDir)/'+StringReplace(CreateRelativePath(Pkg.Filename,PkgDir),'\','/',[rfReplaceAll]);
364    if WriteCommands then begin
365      writeln('echo '''+Line+''' > '+LPLFilename);
366      writeln('svn add '+LPLFilename);
367    end else if ExecuteCommands then begin
368      if not Quiet then
369        writeln('Info: creating '+LPLFilename);
370      sl:=TStringList.Create;
371      try
372        sl.Add(Line);
373        sl.SaveToFile(LPLFilename);
374      finally
375        sl.Free;
376      end;
377      if WriteCommands then
378        writeln('ToDo: svn add '+LPLFilename);
379    end;
380  end;
381end;
382
383procedure TLPLUpdate.WriteLinksWithWrongExpFilename(Packages: TPackages;
384  Links: TLinks);
385var
386  i: Integer;
387  Pkg: TPackage;
388  Link: TLink;
389  LinkFilename: String;
390  sl: TStringList;
391begin
392  for i:=0 to Links.Count-1 do begin
393    Link:=Links[i];
394    Pkg:=Packages.FindByName(Link.PkgName);
395    if Pkg=nil then continue;
396    if (CompareText(ExtractFileNameOnly(Link.ExpFilename),Pkg.Name)<>0)
397    or (not FileExistsUTF8(Link.ExpFilename)) then begin
398      LinkFilename:='$(LazarusDir)/'+StringReplace(CreateRelativePath(Pkg.Filename,PkgDir),'\','/',[rfReplaceAll]);
399      if not (Quiet and WriteCommands) then
400        writeln('Wrong filename in link ',ExtractFileNameOnly(Link.LPLFilename),' should be '+LinkFilename);
401      if WriteCommands then begin
402        writeln('echo ''',LinkFilename+''' > '+Link.LPLFilename);
403      end else if ExecuteCommands then begin
404        if not Quiet then
405          writeln('Info: fixing '+Link.LPLFilename+': '+LinkFilename);
406        sl:=TStringList.Create;
407        try
408          sl.Add(LinkFilename);
409          sl.SaveToFile(Link.LPLFilename);
410        finally
411          sl.Free;
412        end;
413      end;
414    end;
415  end;
416end;
417
418procedure TLPLUpdate.WriteDeadLinks(Packages: TPackages; Links: TLinks);
419// write links that points to non existing packages
420var
421  i: Integer;
422  Link: TLink;
423  Pkg: TPackage;
424begin
425  for i:=0 to Links.Count-1 do begin
426    Link:=Links[i];
427    Pkg:=Packages.FindByName(Link.PkgName);
428    if (Pkg=nil) then begin
429      if not (Quiet and WriteCommands) then begin
430        if CompareText(Link.PkgName,ExtractFileNameOnly(Link.ExpFilename))=0 then
431          writeln('Dead link ',ExtractFileNameOnly(Link.LPLFilename),' to missing '+CreateRelativePath(Link.PkgFilename,PkgDir))
432        else
433          writeln('Wrong link ',ExtractFileNameOnly(Link.LPLFilename),' to '+CreateRelativePath(Link.PkgFilename,PkgDir));
434      end;
435      if WriteCommands then begin
436        writeln('svn rm ',CreateRelativePath(Link.LPLFilename,LazarusDir));
437      end else if ExecuteCommands then begin
438        if not Quiet then
439          writeln('Info: deleting '+Link.LPLFilename);
440        if not DeleteFileUTF8(Link.LPLFilename) then
441          Error('unable to delete file "'+Link.LPLFilename+'"');
442      end;
443    end;
444  end;
445end;
446
447procedure TLPLUpdate.WriteLinksWithWrongVersion(Packages: TPackages;
448  Links: TLinks);
449// write links with different version than the lpk files
450var
451  i: Integer;
452  Link: TLink;
453  j: Integer;
454  Pkg: TPackage;
455  NewLPLFilename, OldLPLFilename: String;
456begin
457  for i:=0 to Links.Count-1 do begin
458    Link:=Links[i];
459    j:=Packages.Count-1;
460    while (j>=0) do begin
461      Pkg:=Packages[j];
462      if (CompareText(Link.PkgName,Pkg.Name)=0)
463      and (CompareFilenames(Link.ExpFilename,Pkg.Filename)=0) then begin
464        if (Link.Major<>Pkg.Major)
465        or (Link.Minor<>Pkg.Minor)
466        or (Link.Release<>Pkg.Release)
467        or (Link.Build<>Pkg.Build)
468        // ignore build
469        then begin
470          if not (Quiet and WriteCommands) then
471            writeln('Version mismatch link ',ExtractFileNameOnly(Link.LPLFilename),' <> ',Pkg.VersionAsString,' in ',CreateRelativePath(Pkg.Filename,PkgDir));
472          OldLPLFilename:=CreateRelativePath(Link.LPLFilename,LazarusDir);
473          NewLPLFilename:=AppendPathDelim(CreateRelativePath(LinksDir,LazarusDir))+Pkg.Name+'-'+Pkg.VersionAsString+'.lpl';
474          if WriteCommands then begin
475            writeln('svn mv ',OldLPLFilename,' ',NewLPLFilename);
476          end else if ExecuteCommands then begin
477            if not Quiet then
478              writeln('Info: renaming "'+OldLPLFilename+'" -> "'+NewLPLFilename+'"');
479            if not RenameFileUTF8(OldLPLFilename,NewLPLFilename) then
480              Error('Unable to rename file "'+OldLPLFilename+'" -> "'+NewLPLFilename+'"');
481          end;
482        end;
483        break;
484      end;
485      dec(j);
486    end;
487  end;
488end;
489
490constructor TLPLUpdate.Create(TheOwner: TComponent);
491begin
492  inherited Create(TheOwner);
493  StopOnException:=True;
494end;
495
496destructor TLPLUpdate.Destroy;
497begin
498  inherited Destroy;
499end;
500
501procedure TLPLUpdate.WriteHelp;
502begin
503  writeln;
504  writeln('Usage: ',ExeName,' -h');
505  writeln;
506  writeln('-L <lazarus directory>, --lazarusdir=<dir>');
507  writeln('    The lazarus source directory.');
508  writeln('    Default is ',GetDefaultLazarusDir);
509  writeln;
510  writeln('-c, --commands');
511  writeln('    Write shell commands to fix issues.');
512  writeln('    Hint: use -q -c to get only the commands.');
513  writeln;
514  writeln('-p <directory of lpk files>, --pkgdir=<dir>');
515  writeln('    The directory where to search for lpk files, including sub directories.');
516  writeln('    Default is ',GetDefaultPkgDirectory);
517  writeln;
518  writeln('-l <directory of lpl files> --linksdir=<dir>');
519  writeln('    The directory where to search for lpl files.');
520  writeln('    Default is ',GetDefaultLinksDirectory);
521  writeln;
522  writeln('-x, --execute');
523  writeln('    Create, delete, rename, alter lpl files.');
524  writeln;
525  writeln('-v, --verbose');
526  writeln;
527  writeln('-q, --quiet');
528  writeln;
529end;
530
531function TLPLUpdate.GetDefaultLazarusDir: string;
532begin
533  if GetEnvironmentVariableUTF8('LAZARUSDIR')<>'' then
534    Result:=GetEnvironmentVariableUTF8('LAZARUSDIR')
535  else begin
536    Result:=ChompPathDelim(GetCurrentDirUTF8);
537    if (ExtractFileName(Result)='tools')
538    and (DirPathExists(ExtractFilePath(Result)+'packager')) then begin
539      // common mistake: lplupdate started in tools
540      Result:=ExtractFilePath(Result)
541    end;
542  end;
543  Result:=CleanAndExpandDirectory(Result);
544end;
545
546function TLPLUpdate.GetLazarusDir: string;
547begin
548  if LazarusDir<>'' then
549    Result:=LazarusDir
550  else
551    Result:=GetDefaultLazarusDir;
552end;
553
554function TLPLUpdate.GetDefaultPkgDirectory: string;
555begin
556  Result:=GetLazarusDir;
557end;
558
559function TLPLUpdate.GetDefaultLinksDirectory: string;
560begin
561  Result:=GetLazarusDir+'packager'+PathDelim+'globallinks'+PathDelim;
562end;
563
564{ TPackages }
565
566function TPackages.GetPackages(Index: integer): TPackage;
567begin
568  Result:=TPackage(Items[Index]);
569end;
570
571function TPackages.IndexByName(PkgName: string): integer;
572begin
573  Result:=Count-1;
574  while (Result>=0) and (CompareText(PkgName,Packages[Result].Name)<>0) do
575    dec(Result);
576end;
577
578function TPackages.FindByName(PkgName: string): TPackage;
579var
580  i: LongInt;
581begin
582  i:=IndexByName(PkgName);
583  if i>=0 then
584    Result:=Packages[i]
585  else
586    Result:=nil;
587end;
588
589function TPackage.VersionAsString: string;
590
591  procedure Add(var s: string; v: integer; Force: boolean = false);
592  begin
593    if Force or (v<>0) or (s<>'') then begin
594      if s<>'' then s:='.'+s;
595      s:=IntToStr(v)+s;
596    end;
597  end;
598
599begin
600  Result:='';
601  Add(Result,Build);
602  Add(Result,Release);
603  Add(Result,Minor);
604  Add(Result,Major,true);
605end;
606
607{ TLinks }
608
609function TLinks.GetLinks(Index: integer): TLink;
610begin
611  Result:=TLink(Items[Index]);
612end;
613
614function TLinks.FindLinkWithName(PkgName: string): TLink;
615var
616  i: Integer;
617begin
618  for i:=0 to Count-1 do begin
619    Result:=Links[i];
620    if CompareText(PkgName,Result.PkgName)=0 then exit;
621  end;
622  Result:=nil;
623end;
624
625var
626  Application: TLPLUpdate;
627
628begin
629  Application:=TLPLUpdate.Create(nil);
630  Application.Run;
631  Application.Free;
632end.
633
634