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