1{ 2 *************************************************************************** 3 * * 4 * This source is free software; you can redistribute it and/or modify * 5 * it under the terms of the GNU General Public License as published by * 6 * the Free Software Foundation; either version 2 of the License, or * 7 * (at your option) any later version. * 8 * * 9 * This code is distributed in the hope that it will be useful, but * 10 * WITHOUT ANY WARRANTY; without even the implied warranty of * 11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * 12 * General Public License for more details. * 13 * * 14 * A copy of the GNU General Public License is available on the World * 15 * Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also * 16 * obtain it by writing to the Free Software Foundation, * 17 * Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. * 18 * * 19 *************************************************************************** 20 21 Simple functions 22 - for file access, not yet in fpc. 23 - recent list 24 - xmlconfig formats 25} 26unit IDEProcs; 27 28{$mode objfpc}{$H+} 29 30interface 31 32uses 33 // RTL 34 Classes, SysUtils, Laz_AVL_Tree, 35 // LazUtils 36 FileUtil, LazFileUtils, LazUtilities, LazFileCache, LazUTF8, 37 Laz2_XMLCfg, AvgLvlTree, LazLoggerBase, LazTracer, 38 // LCL 39 StdCtrls, ExtCtrls, 40 // CodeTools 41 BasicCodeTools, FileProcs, CodeToolManager, CodeToolsConfig, CodeCache, 42 PackageIntf, 43 // IDE 44 TransferMacros, 45 LazConf; 46 47const 48 SBuildMethod: array[TBuildMethod] of string = ( 49 'Lazarus', 50 'FPMake', 51 'Both' 52 ); 53function StringToBuildMethod(const BuildMethod: string): TBuildMethod; 54function GetFPCVer: String; 55 56// file operations 57function BackupFileForWrite(const Filename, BackupFilename: string): boolean; 58function CreateEmptyFile(const Filename: string): boolean; 59 60// file names 61function FilenameIsPascalSource(const Filename: string): boolean; 62function ChompEndNumber(const s: string): string; 63 64// find file 65function FindFilesCaseInsensitive(const Directory, 66 CaseInsensitiveFilename: string; IgnoreExact: boolean): TStringList; 67function FindFirstFileWithExt(const Directory, Ext: string): string; 68function CreateNonExistingFilename(const BaseFilename: string): string; 69function FindFPCTool(const Executable, CompilerFilename: string): string; 70procedure ResolveLinksInFileList(List: TStrings; RemoveDanglingLinks: Boolean); 71function FindProgram(ProgramName, BaseDirectory: string; 72 WithBaseDirectory: boolean): string; 73 74// search paths 75function TrimSearchPath(const SearchPath, BaseDirectory: string; 76 DeleteDoubles: boolean = false; ExpandPaths: boolean = false): string; 77function MergeSearchPaths(const OldSearchPath, AddSearchPath: string): string; 78procedure MergeSearchPaths(SearchPath: TStrings; const AddSearchPath: string); 79function RemoveSearchPaths(const SearchPath, RemoveSearchPath: string): string; 80function RemoveNonExistingPaths(const SearchPath, BaseDirectory: string): string; 81function RebaseSearchPath(const SearchPath, 82 OldBaseDirectory, NewBaseDirectory: string; 83 SkipPathsStartingWithMacro: boolean): string; 84function ShortenSearchPath(const SearchPath, BaseDirectory, 85 ChompDirectory: string): string; 86function GetNextDirectoryInSearchPath(const SearchPath: string; 87 var NextStartPos: integer): string; 88function GetNextUsedDirectoryInSearchPath(const SearchPath, 89 FilterDir: string; var NextStartPos: integer): string; 90function SearchPathToList(const SearchPath: string): TStringList; 91function SearchDirectoryInSearchPath(const SearchPath, Directory: string; 92 DirStartPos: integer = 1): integer; 93function SearchDirectoryInSearchPath(SearchPath: TStrings; 94 const Directory: string; DirStartPos: integer = 0): integer; 95 96// Recent item lists 97type 98 TRecentListType = ( 99 rltCaseSensitive, 100 rltCaseInsensitive, 101 rltFile 102 ); 103const 104 RecentListTypeNames: array[TRecentListType] of string = ( 105 'CaseSensitive', 106 'CaseInsensitive', 107 'File' 108 ); 109function IndexInRecentList(List: TStrings; ListType: TRecentListType; 110 const Path: string): integer; 111function StrToRecentListType(s: string): TRecentListType; 112function CompareRecentListItem(s1, s2: string; ListType: TRecentListType): boolean; 113procedure LoadRecentList(XMLConfig: TXMLConfig; List: TStrings; const Path: string; 114 ListType: TRecentListType); 115procedure SaveRecentList(XMLConfig: TXMLConfig; List: TStrings; 116 const Path: string); overload; 117procedure SaveRecentList(XMLConfig: TXMLConfig; List: TStrings; 118 const Path: string; aMax: Integer); overload; 119function AddToRecentList(const s: string; List: TStrings; aMax: integer; 120 ListType: TRecentListType): boolean; 121function AddComboTextToRecentList(cb: TCombobox; aMax: integer; 122 ListType: TRecentListType): boolean; 123procedure RemoveFromRecentList(const s: string; List: TStrings; 124 ListType: TRecentListType); 125procedure CleanUpRecentList(List: TStrings; ListType: TRecentListType); 126 127// XMLconfig 128procedure LoadRect(XMLConfig: TXMLConfig; const Path:string; 129 var ARect:TRect); 130procedure LoadRect(XMLConfig: TXMLConfig; const Path:string; 131 var ARect:TRect; const DefaultRect: TRect); 132procedure SaveRect(XMLConfig: TXMLConfig; const Path:string; 133 const ARect: TRect); 134procedure SaveRect(XMLConfig: TXMLConfig; const Path:string; 135 const ARect, DefaultRect: TRect); 136procedure LoadPoint(XMLConfig: TXMLConfig; const Path:string; 137 var APoint:TPoint; const DefaultPoint: TPoint); 138procedure SavePoint(XMLConfig: TXMLConfig; const Path:string; 139 const APoint, DefaultPoint:TPoint); 140procedure LoadStringList(XMLConfig: TXMLConfig; List: TStrings; const Path: string); 141procedure SaveStringList(XMLConfig: TXMLConfig; List: TStrings; const Path: string); 142procedure LoadStringToStringTree(XMLConfig: TXMLConfig; 143 Tree: TStringToStringTree; const Path: string); 144procedure SaveStringToStringTree(XMLConfig: TXMLConfig; 145 Tree: TStringToStringTree; const Path: string); 146procedure MakeXMLName(var Name: string); 147function LoadXMLConfigViaCodeBuffer(Filename: string): TXMLConfig; 148 149// Point conversion 150function PointToCfgStr(const Point: TPoint): string; 151procedure CfgStrToPoint(const s: string; var Point: TPoint; const DefaultPoint: TPoint); 152 153// environment 154type 155 TParseString = record 156 UnparsedValue: string; 157 ParsedValue: string; 158 ParseStamp: integer; 159 Parsing: boolean; 160 end; 161 162function GetCurrentUserName: string; 163function GetCurrentChangeLog: string; 164function GetProgramSearchPath: string; 165 166// miscellaneous 167procedure CheckList(List: TList; TestListNil, TestDoubles, TestNils: boolean); 168procedure CheckList(List: TFPList; TestListNil, TestDoubles, TestNils: boolean); 169procedure CheckEmptyListCut(List1, List2: TList); 170procedure RemoveDoubles(List: TStrings); 171function SearchInStringListI(List: TStrings; const s: string): integer; // search ASCII case insensitive, not UTF-8 172procedure ReverseList(List: TList); 173procedure ReverseList(List: TFPList); 174procedure FreeListObjects(List: TList; FreeList: boolean); 175procedure FreeListObjects(List: TFPList; FreeList: boolean); 176function CompareMemStreamText(s1, s2: TMemoryStream): Boolean; 177 178function CheckGroupItemChecked(CheckGroup: TCheckGroup; const Caption: string): Boolean; 179 180 181implementation 182 183{$IfNdef MSWindows} 184{$ifNdef HASAMIGA} 185// to get more detailed error messages consider the os 186uses 187 Unix, BaseUnix; 188{$EndIf} 189{$EndIf} 190 191{------------------------------------------------------------------------------- 192 function FindFilesCaseInsensitive(const Directory, 193 CaseInsensitiveFilename: string; IgnoreExact: boolean): TStringLists; 194 195 Search Pascal case insensitive in Directory for all files 196 named CaseInsensitiveFilename 197-------------------------------------------------------------------------------} 198function FindFilesCaseInsensitive(const Directory, 199 CaseInsensitiveFilename: string; IgnoreExact: boolean): TStringList; 200var 201 FileInfo: TSearchRec; 202begin 203 Result:=nil; 204 if FindFirstUTF8(AppendPathDelim(Directory)+GetAllFilesMask, 205 faAnyFile,FileInfo)=0 206 then begin 207 repeat 208 // check if special file 209 if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') then 210 continue; 211 if (CompareText(CaseInsensitiveFilename,FileInfo.Name)=0) // Pascal insensitibity, not UTF-8, thing about Turkish I 212 and ((not IgnoreExact) 213 or (CompareFilenames(CaseInsensitiveFilename,FileInfo.Name)<>0)) 214 then begin 215 if Result=nil then Result:=TStringList.Create; 216 Result.Add(FileInfo.Name); 217 end; 218 until FindNextUTF8(FileInfo)<>0; 219 end; 220 FindCloseUTF8(FileInfo); 221end; 222 223function FilenameIsPascalSource(const Filename: string): boolean; 224var 225 s: string; 226 i: Integer; 227begin 228 Result:=False; 229 // Check unit name 230 s:=ExtractFileNameOnly(Filename); 231 if (s='') or not IsDottedIdentifier(s) then 232 exit; 233 // Check extension 234 s:=lowercase(ExtractFileExt(Filename)); 235 for i:=Low(PascalSourceExt) to High(PascalSourceExt) do 236 if s=PascalSourceExt[i] then 237 exit(True); 238end; 239 240function CreateNonExistingFilename(const BaseFilename: string): string; 241var 242 PostFix: String; 243 PreFix: String; 244 i: Integer; 245begin 246 if not FileExistsUTF8(BaseFilename) then begin 247 Result:=BaseFilename; 248 exit; 249 end; 250 PostFix:=ExtractFileExt(BaseFilename); 251 PreFix:=copy(BaseFilename,1,length(BaseFilename)-length(PostFix)); 252 i:=0; 253 repeat 254 inc(i); 255 Result:=PreFix+IntToStr(i)+PostFix; 256 until not FileExistsUTF8(Result); 257end; 258 259function FindFPCTool(const Executable, CompilerFilename: string): string; 260begin 261 if ConsoleVerbosity>=0 then 262 DebugLn('Hint: (lazarus) FindFPCTool Executable="',Executable,'" CompilerFilename="',CompilerFilename,'"'); 263 Result:=AppendPathDelim(ExtractFilePath(CompilerFilename))+Executable; 264 if ConsoleVerbosity>=0 then 265 DebugLn('Hint: (lazarus) FindFPCTool Try="',Result); 266 if FileExistsUTF8(Result) then exit; 267 Result:=FindDefaultExecutablePath(Executable); 268 if FileExistsUTF8(Result) then exit; 269 Result:=''; 270end; 271 272procedure ResolveLinksInFileList(List: TStrings; RemoveDanglingLinks: Boolean); 273var 274 i: Integer; 275 OldFilename: string; 276 NewFilename: String; 277begin 278 if List=nil then exit; 279 for i:=List.Count-1 downto 0 do begin 280 OldFilename:=List[i]; 281 NewFilename:=GetPhysicalFilenameCached(OldFilename,true); 282 //DebugLn(['ResolveLinksInFileList OldFilename=',OldFilename,' NewFilename=',NewFilename]); 283 if NewFilename='' then begin 284 if RemoveDanglingLinks then 285 List.Delete(i); 286 end 287 else if NewFilename<>OldFilename then 288 List[i]:=NewFilename; 289 end; 290end; 291 292function MergeSearchPaths(const OldSearchPath, AddSearchPath: string): string; 293var 294 l: Integer; 295 EndPos: Integer; 296 StartPos: Integer; 297 NewPath: String; 298begin 299 Result:=OldSearchPath; 300 if Result='' then begin 301 Result:=AddSearchPath; 302 exit; 303 end; 304 l:=length(AddSearchPath); 305 EndPos:=1; 306 while EndPos<=l do begin 307 StartPos:=EndPos; 308 while (AddSearchPath[StartPos]=';') do begin 309 inc(StartPos); 310 if StartPos>l then exit; 311 end; 312 EndPos:=StartPos; 313 while (EndPos<=l) and (AddSearchPath[EndPos]<>';') do inc(EndPos); 314 if SearchDirectoryInSearchPath(Result,AddSearchPath,StartPos)<1 then 315 begin 316 // new path found -> add 317 NewPath:=copy(AddSearchPath,StartPos,EndPos-StartPos); 318 if Result<>'' then 319 NewPath:=';'+NewPath; 320 Result:=Result+NewPath; 321 end; 322 end; 323end; 324 325procedure MergeSearchPaths(SearchPath: TStrings; const AddSearchPath: string); 326var 327 l: Integer; 328 EndPos: Integer; 329 StartPos: Integer; 330begin 331 l:=length(AddSearchPath); 332 EndPos:=1; 333 while EndPos<=l do begin 334 StartPos:=EndPos; 335 while (AddSearchPath[StartPos]=';') do begin 336 inc(StartPos); 337 if StartPos>l then exit; 338 end; 339 EndPos:=StartPos; 340 while (EndPos<=l) and (AddSearchPath[EndPos]<>';') do inc(EndPos); 341 if SearchDirectoryInSearchPath(SearchPath,AddSearchPath,StartPos)<1 then 342 begin 343 // new path found -> add 344 SearchPath.Add(copy(AddSearchPath,StartPos,EndPos-StartPos)); 345 end; 346 end; 347end; 348 349function RemoveSearchPaths(const SearchPath, RemoveSearchPath: string): string; 350var 351 OldPathLen: Integer; 352 EndPos: Integer; 353 StartPos: Integer; 354 ResultStartPos: Integer; 355begin 356 Result:=SearchPath; 357 OldPathLen:=length(SearchPath); 358 EndPos:=1; 359 ResultStartPos:=1; 360 repeat 361 StartPos:=EndPos; 362 while (StartPos<=OldPathLen) and (SearchPath[StartPos]=';') do 363 inc(StartPos); 364 if StartPos>OldPathLen then break; 365 EndPos:=StartPos; 366 while (EndPos<=OldPathLen) and (SearchPath[EndPos]<>';') do 367 inc(EndPos); 368 //DebugLn('RemoveSearchPaths Dir="',copy(SearchPath,StartPos,EndPos-StartPos),'" RemoveSearchPath="',RemoveSearchPath,'"'); 369 if SearchDirectoryInSearchPath(RemoveSearchPath,SearchPath,StartPos)>0 then 370 begin 371 // remove path -> skip 372 end else begin 373 // keep path -> copy 374 if ResultStartPos>1 then begin 375 Result[ResultStartPos]:=';'; 376 inc(ResultStartPos); 377 end; 378 while StartPos<EndPos do begin 379 Result[ResultStartPos]:=SearchPath[StartPos]; 380 inc(ResultStartPos); 381 inc(StartPos); 382 end; 383 end; 384 until false; 385 SetLength(Result,ResultStartPos-1); 386end; 387 388function RebaseSearchPath(const SearchPath, OldBaseDirectory, 389 NewBaseDirectory: string; SkipPathsStartingWithMacro: boolean): string; 390// change every relative search path 391var 392 EndPos: Integer; 393 StartPos: Integer; 394 CurPath: String; 395begin 396 Result:=SearchPath; 397 if CompareFilenames(OldBaseDirectory,NewBaseDirectory)=0 then exit; 398 EndPos:=1; 399 repeat 400 StartPos:=EndPos; 401 while (StartPos<=length(Result)) and (Result[StartPos]=';') do 402 inc(StartPos); 403 if StartPos>length(Result) then break; 404 EndPos:=StartPos; 405 while (EndPos<=length(Result)) and (Result[EndPos]<>';') do 406 inc(EndPos); 407 if EndPos>StartPos then begin 408 CurPath:=copy(Result,StartPos,EndPos-StartPos); 409 if (not FilenameIsAbsolute(CurPath)) 410 and ((not SkipPathsStartingWithMacro) or (CurPath[1]<>'$')) 411 then begin 412 CurPath:=TrimFilename(AppendPathDelim(OldBaseDirectory)+CurPath); 413 CurPath:=CreateRelativePath(CurPath,NewBaseDirectory); 414 Result:=copy(Result,1,StartPos-1)+CurPath 415 +copy(Result,EndPos,length(Result)); 416 EndPos:=StartPos+length(CurPath); 417 end; 418 end; 419 until false; 420end; 421 422function ShortenSearchPath(const SearchPath, BaseDirectory, 423 ChompDirectory: string): string; 424// Every search path that is a subdirectory of ChompDirectory will be shortened. 425// Before the test relative paths are expanded by BaseDirectory. 426var 427 BaseEqualsChompDir: boolean; 428 429 function Normalize(var ADirectory: string): boolean; 430 begin 431 if FilenameIsAbsolute(ADirectory) then begin 432 Result:=true; 433 end else begin 434 if BaseEqualsChompDir then 435 Result:=false 436 else begin 437 Result:=true; 438 ADirectory:=AppendPathDelim(BaseDirectory)+ADirectory; 439 end; 440 end; 441 if Result then 442 ADirectory:=AppendPathDelim(TrimFilename(ADirectory)); 443 end; 444 445var 446 PathLen: Integer; 447 EndPos: Integer; 448 StartPos: Integer; 449 CurDir: String; 450 NewCurDir: String; 451 DiffLen: Integer; 452begin 453 Result:=SearchPath; 454 if (SearchPath='') or (ChompDirectory='') then exit; 455 456 PathLen:=length(Result); 457 EndPos:=1; 458 BaseEqualsChompDir:=CompareFilenames(BaseDirectory,ChompDirectory)=0; 459 while EndPos<=PathLen do begin 460 StartPos:=EndPos; 461 while (Result[StartPos] in [';',#0..#32]) do begin 462 inc(StartPos); 463 if StartPos>PathLen then exit; 464 end; 465 EndPos:=StartPos; 466 while (EndPos<=PathLen) and (Result[EndPos]<>';') do inc(EndPos); 467 CurDir:=copy(Result,StartPos,EndPos-StartPos); 468 NewCurDir:=CurDir; 469 if Normalize(NewCurDir) then begin 470 if CompareFilenames(NewCurDir,ChompDirectory)=0 then 471 NewCurDir:='.' 472 else if FileIsInPath(NewCurDir,ChompDirectory) then 473 NewCurDir:=AppendPathDelim(CreateRelativePath(NewCurDir,BaseDirectory)); 474 if NewCurDir<>CurDir then begin 475 DiffLen:=length(NewCurDir)-length(CurDir); 476 Result:=copy(Result,1,StartPos-1)+NewCurDir 477 +copy(Result,EndPos,PathLen-EndPos+1); 478 inc(EndPos,DiffLen); 479 inc(PathLen,DiffLen); 480 end; 481 end; 482 StartPos:=EndPos; 483 end; 484end; 485 486function GetNextDirectoryInSearchPath(const SearchPath: string; 487 var NextStartPos: integer): string; 488var 489 PathLen: Integer; 490 CurStartPos: Integer; 491begin 492 PathLen:=length(SearchPath); 493 if PathLen>0 then begin 494 repeat 495 while (NextStartPos<=PathLen) 496 and (SearchPath[NextStartPos] in [';',#0..#32]) do 497 inc(NextStartPos); 498 CurStartPos:=NextStartPos; 499 while (NextStartPos<=PathLen) and (SearchPath[NextStartPos]<>';') do 500 inc(NextStartPos); 501 Result:=TrimFilename(copy(SearchPath,CurStartPos,NextStartPos-CurStartPos)); 502 if Result<>'' then exit; 503 until (NextStartPos>PathLen); 504 end else begin 505 NextStartPos:=1; 506 end; 507 Result:=''; 508end; 509 510function GetNextUsedDirectoryInSearchPath(const SearchPath, 511 FilterDir: string; var NextStartPos: integer): string; 512// searches next directory in search path, 513// which is equal to FilterDir or is in FilterDir 514begin 515 while (NextStartPos<=length(SearchPath)) do begin 516 Result:=GetNextDirectoryInSearchPath(SearchPath,NextStartPos); 517 if (Result<>'') and PathIsInPath(Result,FilterDir) then 518 exit; 519 end; 520 Result:='' 521end; 522 523function SearchPathToList(const SearchPath: string): TStringList; 524var 525 p: Integer; 526 CurDir: String; 527begin 528 Result:=TStringList.Create; 529 p:=1; 530 repeat 531 CurDir:=GetNextDirectoryInSearchPath(SearchPath,p); 532 if CurDir='' then break; 533 Result.Add(CurDir); 534 until false; 535end; 536 537function SearchDirectoryInSearchPath(const SearchPath, Directory: string; 538 DirStartPos: integer): integer; 539// -1 on not found 540var 541 PathLen: Integer; 542 DirLen: Integer; 543 EndPos: Integer; 544 StartPos: Integer; 545 DirEndPos: Integer; 546 CurDirLen: Integer; 547 CurDirEndPos: Integer; 548begin 549 Result:=-1; 550 DirLen:=length(Directory); 551 if (SearchPath='') 552 or (Directory='') or (DirStartPos>DirLen) or (Directory[DirStartPos]=';') then 553 exit; 554 DirEndPos:=DirStartPos; 555 while (DirEndPos<=DirLen) and (Directory[DirEndPos]<>';') do inc(DirEndPos); 556 // ignore PathDelim at end 557 if (DirEndPos>DirStartPos) and (Directory[DirEndPos-1]=PathDelim) then begin 558 while (DirEndPos>DirStartPos) and (Directory[DirEndPos-1]=PathDelim) do 559 dec(DirEndPos); 560 // check if it is the root path '/' 561 if DirEndPos=DirStartPos then DirEndPos:=DirStartPos+1; 562 end; 563 CurDirLen:=DirEndPos-DirStartPos; 564 //DebugLn('SearchDirectoryInSearchPath Dir="',copy(Directory,DirStartPos,CurDirLen),'"'); 565 PathLen:=length(SearchPath); 566 EndPos:=1; 567 while EndPos<=PathLen do begin 568 StartPos:=EndPos; 569 while (SearchPath[StartPos] in [';',#0..#32]) do begin 570 inc(StartPos); 571 if StartPos>PathLen then exit; 572 end; 573 EndPos:=StartPos; 574 while (EndPos<=PathLen) and (SearchPath[EndPos]<>';') do inc(EndPos); 575 CurDirEndPos:=EndPos; 576 // ignore PathDelim at end 577 if (CurDirEndPos>StartPos) and (SearchPath[CurDirEndPos-1]=PathDelim) then 578 begin 579 while (CurDirEndPos>StartPos) and (SearchPath[CurDirEndPos-1]=PathDelim) 580 do 581 dec(CurDirEndPos); 582 // check if it is the root path '/' 583 if CurDirEndPos=StartPos then CurDirEndPos:=StartPos+1; 584 end; 585 //DebugLn('SearchDirectoryInSearchPath CurDir="',copy(SearchPath,StartPos,CurDirEndPos-StartPos),'"'); 586 if CurDirEndPos-StartPos=CurDirLen then begin 587 // directories have same length -> compare chars 588 if FileUtil.CompareFilenames(@SearchPath[StartPos],CurDirLen, 589 @Directory[DirStartPos],CurDirLen, 590 false)=0 591 then begin 592 // directory found 593 Result:=StartPos; 594 exit; 595 end; 596 end; 597 StartPos:=EndPos; 598 end; 599end; 600 601function SearchDirectoryInSearchPath(SearchPath: TStrings; 602 const Directory: string; DirStartPos: integer): integer; 603var 604 DirLen: Integer; 605 DirEndPos: Integer; 606 CurDirLen: Integer; 607 CurPath: string; 608 CurPathLen: Integer; 609begin 610 Result:=-1; 611 DirLen:=length(Directory); 612 if (SearchPath.Count=0) 613 or (Directory='') or (DirStartPos>DirLen) or (Directory[DirStartPos]=';') then 614 exit; 615 DirEndPos:=DirStartPos; 616 while (DirEndPos<=DirLen) and (Directory[DirEndPos]<>';') do inc(DirEndPos); 617 // ignore PathDelim at end 618 if (DirEndPos>DirStartPos) and (Directory[DirEndPos-1]=PathDelim) then begin 619 while (DirEndPos>DirStartPos) and (Directory[DirEndPos-1]=PathDelim) do 620 dec(DirEndPos); 621 // check if it is the root path '/' 622 if DirEndPos=DirStartPos then DirEndPos:=DirStartPos+1; 623 end; 624 CurDirLen:=DirEndPos-DirStartPos; 625 626 // search in all search paths 627 Result:=SearchPath.Count-1; 628 while Result>=0 do begin 629 CurPath:=SearchPath[Result]; 630 CurPathLen:=length(CurPath); 631 if CurPathLen>0 then 632 begin 633 while (CurPathLen>1) and (CurPath[CurPathLen]=PathDelim) do dec(CurPathLen); 634 end; 635 if (CurPathLen>0) 636 and (FileUtil.CompareFilenames(@CurPath[1],CurPathLen, 637 @Directory[DirStartPos],CurDirLen, 638 false)=0) 639 then begin 640 // directory found 641 exit; 642 end; 643 dec(Result); 644 end; 645end; 646 647function RemoveNonExistingPaths(const SearchPath, BaseDirectory: string): string; 648var 649 StartPos: Integer; 650 EndPos: LongInt; 651 CurPath: String; 652 MacroStartPos: LongInt; 653begin 654 Result:=SearchPath; 655 StartPos:=1; 656 while StartPos<=length(Result) do begin 657 EndPos:=StartPos; 658 while (EndPos<=length(Result)) and (Result[EndPos]=';') do inc(EndPos); 659 if EndPos>StartPos then begin 660 // empty paths, e.g. ;;;; 661 // remove 662 Result:=copy(Result,1,StartPos-1)+copy(Result,EndPos,length(Result)); 663 EndPos:=StartPos; 664 end; 665 while (EndPos<=length(Result)) and (Result[EndPos]<>';') do inc(EndPos); 666 667 CurPath:=copy(Result,StartPos,EndPos-StartPos); 668 669 // cut macros 670 MacroStartPos:=System.Pos('$(',CurPath); 671 if MacroStartPos>0 then begin 672 CurPath:=copy(CurPath,1,MacroStartPos-1); 673 if (CurPath<>'') and (CurPath[length(CurPath)]<>PathDelim) then 674 CurPath:=ExtractFilePath(CurPath); 675 end; 676 677 // make path absolute 678 if (CurPath<>'') and (not FilenameIsAbsolute(CurPath)) then 679 CurPath:=AppendPathDelim(BaseDirectory)+CurPath; 680 681 if ((CurPath='') and (MacroStartPos<1)) 682 or (not DirPathExistsCached(CurPath)) then begin 683 // path does not exist -> remove 684 Result:=copy(Result,1,StartPos-1)+copy(Result,EndPos+1,length(Result)); 685 EndPos:=StartPos; 686 end else begin 687 StartPos:=EndPos+1; 688 end; 689 end; 690end; 691 692function StringToBuildMethod(const BuildMethod: string): TBuildMethod; 693begin 694 if BuildMethod=SBuildMethod[bmFPMake] then 695 result := bmFPMake 696 else if BuildMethod=SBuildMethod[bmBoth] then 697 result := bmBoth 698 else 699 result := bmLazarus; 700end; 701 702function GetFPCVer: String; 703begin 704 Result:='$(FPCVer)'; 705 GlobalMacroList.SubstituteStr(Result); 706end; 707 708function ChompEndNumber(const s: string): string; 709var 710 NewLen: Integer; 711begin 712 Result:=s; 713 NewLen:=length(Result); 714 while (NewLen>0) and (Result[NewLen] in ['0'..'9']) do 715 dec(NewLen); 716 SetLength(Result,NewLen); 717end; 718 719function FindFirstFileWithExt(const Directory, Ext: string): string; 720var 721 FileInfo: TSearchRec; 722begin 723 Result:=''; 724 if FindFirstUTF8(AppendPathDelim(Directory)+GetAllFilesMask, 725 faAnyFile,FileInfo)=0 726 then begin 727 repeat 728 // check if special file 729 if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') then 730 continue; 731 // check extension 732 if FilenameExtIs(FileInfo.Name,Ext,false) then begin 733 Result:=AppendPathDelim(Directory)+FileInfo.Name; 734 break; 735 end; 736 until FindNextUTF8(FileInfo)<>0; 737 end; 738 FindCloseUTF8(FileInfo); 739end; 740 741// Recent item lists : 742 743function IndexInRecentList(List: TStrings; ListType: TRecentListType; 744 const Path: string): integer; 745begin 746 Result:=List.Count-1; 747 while (Result>=0) and (not CompareRecentListItem(List[Result],Path,ListType)) do 748 dec(Result); 749end; 750 751function StrToRecentListType(s: string): TRecentListType; 752begin 753 for Result:=Low(TRecentListType) to high(TRecentListType) do 754 if SysUtils.CompareText(s,RecentListTypeNames[Result])=0 then exit; 755 Result:=rltCaseSensitive; 756end; 757 758function CompareRecentListItem(s1, s2: string; ListType: TRecentListType): boolean; 759begin 760 case ListType of 761 rltCaseInsensitive: Result:=UTF8CompareLatinTextFast(s1,s2)=0; 762 rltFile: Result:=CompareFilenames(ChompPathDelim(s1),ChompPathDelim(s2))=0; 763 else Result:=s1=s2; 764 end; 765end; 766 767procedure LoadRecentList(XMLConfig: TXMLConfig; List: TStrings; 768 const Path: string; ListType: TRecentListType); 769begin 770 LoadStringList(XMLConfig,List,Path); 771 CleanUpRecentList(List,ListType); 772end; 773 774procedure SaveRecentList(XMLConfig: TXMLConfig; List: TStrings; const Path: string); 775begin 776 SaveStringList(XMLConfig,List,Path); 777end; 778 779procedure SaveRecentList(XMLConfig: TXMLConfig; List: TStrings; 780 const Path: string; aMax: Integer); 781var 782 i: Integer; 783 s: String; 784begin 785 if aMax>0 then 786 while List.Count>aMax do // Truncate list to aMax items. 787 List.Delete(List.Count-1); 788 SaveStringList(XMLConfig,List,Path); 789 i:=List.Count+1; 790 while True do 791 begin 792 s:=Path+'Item'+IntToStr(i); 793 if not XMLConfig.HasPath(s+'/Value',True) then Break; 794 XMLConfig.DeletePath(s); // Remove excess items from XML. 795 Inc(i); 796 end; 797end; 798 799function AddToRecentList(const s: string; List: TStrings; aMax: integer; 800 ListType: TRecentListType): boolean; 801begin 802 if (List.Count>0) and CompareRecentListItem(List[0],s,ListType) then 803 exit(false); 804 Result:=true; 805 RemoveFromRecentList(s,List,ListType); 806 List.Insert(0,s); 807 if aMax>0 then 808 while List.Count>aMax do 809 List.Delete(List.Count-1); 810end; 811 812function AddComboTextToRecentList(cb: TCombobox; aMax: integer; 813 ListType: TRecentListType): boolean; 814var 815 List: TStringList; 816begin 817 List:=TStringList.Create; 818 try 819 List.Assign(cb.Items); 820 Result:=AddToRecentList(cb.Text,List,aMax,ListType); 821 if Result then 822 begin 823 cb.Items.Assign(List); 824 cb.ItemIndex:=0; 825 end; 826 finally 827 List.Free; 828 end; 829end; 830 831procedure RemoveFromRecentList(const s: string; List: TStrings; 832 ListType: TRecentListType); 833var 834 i: integer; 835begin 836 for i:=List.Count-1 downto 0 do 837 if CompareRecentListItem(List[i],s,ListType) then 838 List.Delete(i); 839end; 840 841procedure CleanUpRecentList(List: TStrings; ListType: TRecentListType); 842var 843 i: Integer; 844begin 845 for i:=List.Count-1 downto 1 do 846 if (List[i]='') or CompareRecentListItem(List[i],List[i-1],ListType) then 847 List.Delete(i); 848end; 849 850// XMLConfig 851 852procedure LoadStringList(XMLConfig: TXMLConfig; List: TStrings; const Path: string); 853var 854 i,Count: integer; 855 s: string; 856begin 857 Count:=XMLConfig.GetValue(Path+'Count',0); 858 List.Clear; 859 for i:=1 to Count do begin 860 s:=XMLConfig.GetValue(Path+'Item'+IntToStr(i)+'/Value',''); 861 if s<>'' then List.Add(s); 862 end; 863end; 864 865procedure SaveStringList(XMLConfig: TXMLConfig; List: TStrings; const Path: string); 866var 867 i: integer; 868begin 869 XMLConfig.SetDeleteValue(Path+'Count',List.Count,0); 870 for i:=0 to List.Count-1 do 871 XMLConfig.SetDeleteValue(Path+'Item'+IntToStr(i+1)+'/Value',List[i],''); 872end; 873 874procedure LoadStringToStringTree(XMLConfig: TXMLConfig; 875 Tree: TStringToStringTree; const Path: string); 876var 877 Cnt: LongInt; 878 SubPath: String; 879 CurName: String; 880 CurValue: String; 881 i: Integer; 882begin 883 Tree.Clear; 884 Cnt:=XMLConfig.GetValue(Path+'Count',0); 885 for i:=0 to Cnt-1 do begin 886 SubPath:=Path+'Item'+IntToStr(i)+'/'; 887 CurName:=XMLConfig.GetValue(SubPath+'Name',''); 888 CurValue:=XMLConfig.GetValue(SubPath+'Value',''); 889 Tree.Values[CurName]:=CurValue; 890 end; 891end; 892 893procedure SaveStringToStringTree(XMLConfig: TXMLConfig; 894 Tree: TStringToStringTree; const Path: string); 895var 896 Node: TAvlTreeNode; 897 Item: PStringToStringItem; 898 i: Integer; 899 SubPath: String; 900begin 901 XMLConfig.SetDeleteValue(Path+'Count',Tree.Tree.Count,0); 902 Node:=Tree.Tree.FindLowest; 903 i:=0; 904 while Node<>nil do begin 905 Item:=PStringToStringItem(Node.Data); 906 SubPath:=Path+'Item'+IntToStr(i)+'/'; 907 XMLConfig.SetDeleteValue(SubPath+'Name',Item^.Name,''); 908 XMLConfig.SetDeleteValue(SubPath+'Value',Item^.Value,''); 909 Node:=Tree.Tree.FindSuccessor(Node); 910 inc(i); 911 end; 912end; 913 914procedure MakeXMLName(var Name: string); 915var 916 i: Integer; 917begin 918 i:=1; 919 while i<=length(Name) do begin 920 if (Name[i] in ['a'..'z','A'..'Z','_']) 921 or (i>1) and (Name[i] in ['0'..'9']) then begin 922 inc(i); 923 end else begin 924 System.Delete(Name,i,1); 925 end; 926 end; 927end; 928 929function LoadXMLConfigViaCodeBuffer(Filename: string): TXMLConfig; 930var 931 Code: TCodeBuffer; 932begin 933 Result:=nil; 934 Code:=CodeToolBoss.LoadFile(Filename,true,false); 935 if Code=nil then exit; 936 try 937 Result:=TCodeBufXMLConfig.CreateWithCache(Filename); 938 except 939 on E: Exception do begin 940 debugln(['LoadXMLConfigViaCodeBuffer Filename="',Filename,'": ',E.Message]); 941 end; 942 end; 943end; 944 945procedure LoadRect(XMLConfig: TXMLConfig; const Path: string; 946 var ARect: TRect); 947begin 948 LoadRect(XMLConfig,Path,ARect,Rect(0,0,0,0)); 949end; 950 951procedure LoadRect(XMLConfig: TXMLConfig; const Path:string; var ARect:TRect; 952 const DefaultRect: TRect); 953begin 954 ARect.Left:=XMLConfig.GetValue(Path+'Left',DefaultRect.Left); 955 ARect.Top:=XMLConfig.GetValue(Path+'Top',DefaultRect.Top); 956 ARect.Right:=XMLConfig.GetValue(Path+'Right',DefaultRect.Right); 957 ARect.Bottom:=XMLConfig.GetValue(Path+'Bottom',DefaultRect.Bottom); 958end; 959 960procedure SaveRect(XMLConfig: TXMLConfig; const Path: string; const ARect: TRect); 961begin 962 SaveRect(XMLConfig,Path,ARect,Rect(0,0,0,0)); 963end; 964 965procedure SaveRect(XMLConfig: TXMLConfig; const Path:string; 966 const ARect, DefaultRect: TRect); 967begin 968 XMLConfig.SetDeleteValue(Path+'Left',ARect.Left,DefaultRect.Left); 969 XMLConfig.SetDeleteValue(Path+'Top',ARect.Top,DefaultRect.Top); 970 XMLConfig.SetDeleteValue(Path+'Right',ARect.Right,DefaultRect.Right); 971 XMLConfig.SetDeleteValue(Path+'Bottom',ARect.Bottom,DefaultRect.Bottom); 972end; 973 974procedure LoadPoint(XMLConfig: TXMLConfig; const Path: string; 975 var APoint: TPoint; const DefaultPoint: TPoint); 976begin 977 APoint.X:=XMLConfig.GetValue(Path+'X',DefaultPoint.X); 978 APoint.Y:=XMLConfig.GetValue(Path+'Y',DefaultPoint.Y); 979end; 980 981procedure SavePoint(XMLConfig: TXMLConfig; const Path: string; 982 const APoint, DefaultPoint: TPoint); 983begin 984 XMLConfig.SetDeleteValue(Path+'X',APoint.X,DefaultPoint.X); 985 XMLConfig.SetDeleteValue(Path+'Y',APoint.Y,DefaultPoint.Y); 986end; 987 988procedure CheckList(List: TList; TestListNil, TestDoubles, TestNils: boolean); 989var 990 Cnt: Integer; 991 i: Integer; 992 CurItem: Pointer; 993 j: Integer; 994begin 995 if List=nil then begin 996 if TestListNil then 997 RaiseGDBException('CheckList List is Nil'); 998 exit; 999 end; 1000 Cnt:=List.Count; 1001 if TestNils then begin 1002 for i:=0 to Cnt-1 do 1003 if List[i]=nil then 1004 RaiseGDBException('CheckList item is Nil'); 1005 end; 1006 if TestDoubles then begin 1007 for i:=0 to Cnt-2 do begin 1008 CurItem:=List[i]; 1009 for j:=i+1 to Cnt-1 do begin 1010 if List[j]=CurItem then 1011 RaiseGDBException('CheckList Double'); 1012 end; 1013 end; 1014 end; 1015end; 1016 1017procedure CheckList(List: TFPList; TestListNil, TestDoubles, TestNils: boolean); 1018var 1019 Cnt: Integer; 1020 i: Integer; 1021 CurItem: Pointer; 1022 j: Integer; 1023begin 1024 if List=nil then begin 1025 if TestListNil then 1026 RaiseGDBException('CheckList List is Nil'); 1027 exit; 1028 end; 1029 Cnt:=List.Count; 1030 if TestNils then begin 1031 for i:=0 to Cnt-1 do 1032 if List[i]=nil then 1033 RaiseGDBException('CheckList item is Nil'); 1034 end; 1035 if TestDoubles then begin 1036 for i:=0 to Cnt-2 do begin 1037 CurItem:=List[i]; 1038 for j:=i+1 to Cnt-1 do begin 1039 if List[j]=CurItem then 1040 RaiseGDBException('CheckList Double'); 1041 end; 1042 end; 1043 end; 1044end; 1045 1046procedure CheckEmptyListCut(List1, List2: TList); 1047var 1048 Cnt1: Integer; 1049 i: Integer; 1050begin 1051 if (List1=nil) or (List2=nil) then exit; 1052 Cnt1:=List1.Count; 1053 for i:=0 to Cnt1 do begin 1054 if List2.IndexOf(List1[i])>=0 then 1055 RaiseGDBException('CheckEmptyListCut'); 1056 end; 1057end; 1058 1059procedure RemoveDoubles(List: TStrings); 1060var 1061 i: Integer; 1062 List2: TStringListUTF8Fast; 1063begin 1064 if List=nil then exit; 1065 List2:=TStringListUTF8Fast.Create; 1066 List2.AddStrings(List); 1067 List2.Sort; 1068 List.Assign(List2); 1069 List2.Free; 1070 for i:=List.Count-2 downto 0 do begin 1071 if List[i]=List[i+1] then List.Delete(i+1); 1072 end; 1073end; 1074 1075function SearchInStringListI(List: TStrings; const s: string): integer; 1076begin 1077 if List=nil then exit(-1); 1078 Result:=List.Count-1; 1079 while (Result>=0) and (CompareText(List[Result],s)<>0) do dec(Result); 1080end; 1081 1082{------------------------------------------------------------------------------- 1083 procedure ReverseList(List: TList); 1084 1085 Reverse the order of a TList 1086-------------------------------------------------------------------------------} 1087procedure ReverseList(List: TList); 1088var 1089 i: Integer; 1090 j: Integer; 1091begin 1092 if List=nil then exit; 1093 i:=0; 1094 j:=List.Count-1; 1095 while i<j do begin 1096 List.Exchange(i,j); 1097 inc(i); 1098 dec(j); 1099 end; 1100end; 1101 1102procedure ReverseList(List: TFPList); 1103var 1104 i: Integer; 1105 j: Integer; 1106begin 1107 if List=nil then exit; 1108 i:=0; 1109 j:=List.Count-1; 1110 while i<j do begin 1111 List.Exchange(i,j); 1112 inc(i); 1113 dec(j); 1114 end; 1115end; 1116 1117procedure FreeListObjects(List: TList; FreeList: boolean); 1118var 1119 i: Integer; 1120begin 1121 for i:=0 to List.Count-1 do 1122 TObject(List[i]).Free; 1123 List.Clear; 1124 if FreeList then 1125 List.Free; 1126end; 1127 1128procedure FreeListObjects(List: TFPList; FreeList: boolean); 1129var 1130 i: Integer; 1131begin 1132 if List=nil then exit; 1133 for i:=0 to List.Count-1 do 1134 TObject(List[i]).Free; 1135 List.Clear; 1136 if FreeList then 1137 List.Free; 1138end; 1139 1140{------------------------------------------------------------------------------- 1141 function TrimSearchPath(const SearchPath, BaseDirectory: string): boolean; 1142 1143 - Removes empty paths. 1144 - Uses TrimFilename on every path. 1145 - If BaseDirectory<>'' then every relative Filename will be expanded. 1146 - removes doubles 1147-------------------------------------------------------------------------------} 1148function TrimSearchPath(const SearchPath, BaseDirectory: string; 1149 DeleteDoubles: boolean; ExpandPaths: boolean): string; 1150var 1151 CurPath: String; 1152 EndPos: Integer; 1153 StartPos: Integer; 1154 len: Integer; 1155 BaseDir: String; 1156begin 1157 Result:=''; 1158 EndPos:=1; 1159 len:=length(SearchPath); 1160 BaseDir:=AppendPathDelim(TrimFilename(BaseDirectory)); 1161 while EndPos<=len do begin 1162 StartPos:=EndPos; 1163 // skip empty paths and space chars at start 1164 while (StartPos<=len) and (SearchPath[StartPos] in [';',#0..#32]) do 1165 inc(StartPos); 1166 if StartPos>len then break; 1167 EndPos:=StartPos; 1168 while (EndPos<=len) and (SearchPath[EndPos]<>';') do inc(EndPos); 1169 CurPath:=copy(SearchPath,StartPos,EndPos-StartPos); 1170 if CurPath<>'' then begin 1171 // non empty path => expand, trim and normalize 1172 if ExpandPaths then 1173 CurPath:=TrimAndExpandDirectory(CurPath,BaseDir) 1174 else if (BaseDir<>'') and (not FilenameIsAbsolute(CurPath)) then 1175 CurPath:=BaseDir+CurPath; 1176 CurPath:=ChompPathDelim(TrimFilename(CurPath)); 1177 if CurPath='' then CurPath:='.'; 1178 // check if path already exists 1179 if (not DeleteDoubles) or (SearchDirectoryInSearchPath(Result,CurPath)<1) 1180 then begin 1181 if Result<>'' then 1182 CurPath:=';'+CurPath; 1183 if CurPath<>'' then 1184 Result:=Result+CurPath 1185 else 1186 Result:=Result+'.'; 1187 end; 1188 end; 1189 end; 1190end; 1191 1192{------------------------------------------------------------------------------- 1193 BackupFileForWrite 1194 1195 Params: const Filename, BackupFilename: string 1196 Result: boolean 1197 1198 Rename Filename to Backupfilename and create empty Filename with same 1199 file attributes 1200-------------------------------------------------------------------------------} 1201function BackupFileForWrite(const Filename, BackupFilename: string): boolean; 1202 1203 function FileIsLocked(const {%H-}FileName: String): Boolean; 1204 {$ifdef Windows} 1205 var 1206 FHandle: THandle; 1207 {$endif} 1208 begin 1209 {$ifdef Windows} 1210 // try to open with all denies 1211 FHandle := FileOpen(UTF8ToSys(FileName), fmOpenRead or fmShareDenyRead or fmShareDenyWrite); 1212 Result := FHandle = feInvalidHandle; 1213 if not Result then 1214 FileClose(FHandle); 1215 {$else} 1216 Result := False; 1217 {$endif} 1218 end; 1219 1220var 1221 FHandle: THandle; 1222 Code: TCodeBuffer; 1223 {$IF defined(MSWindows) or defined(HASAMIGA)} 1224 OldAttr: Longint; 1225 {$ELSE} 1226 OldInfo: Stat; 1227 {$ENDIF} 1228begin 1229 Result := False; 1230 1231 // store file attributes 1232 {$IF defined(MSWindows) or defined(HASAMIGA)} 1233 OldAttr := FileGetAttrUTF8(Filename); 1234 {$ELSE} 1235 if FpStat(Filename, OldInfo{%H-})<>0 then 1236 exit; // can't backup this file 1237 {$ENDIF} 1238 1239 // if not a symlink/hardlink or locked => rename old file (quick), create empty new file 1240 if not FileIsSymlink(Filename) and 1241 not FileIsHardLink(FileName) and 1242 not FileIsLocked(Filename) and 1243 RenameFileUTF8(Filename, BackupFilename) then 1244 begin 1245 // create empty file 1246 FHandle := FileCreate(UTF8ToSys(FileName)); 1247 FileClose(FHandle); 1248 Code:=CodeToolBoss.FindFile(Filename); 1249 if Code<>nil then 1250 Code.InvalidateLoadDate; 1251 end 1252 else // file is a symlink/hardlink or locked or rename failed => copy file (slow) 1253 if not CopyFile(Filename, BackupFilename) then exit; 1254 1255 // restore file attributes 1256 {$IFdef MSWindows} 1257 FileSetAttrUTF8(FileName, OldAttr); 1258 {$ELSE} 1259 FpChmod(Filename, OldInfo.st_Mode and (STAT_IRWXO+STAT_IRWXG+STAT_IRWXU 1260 +STAT_ISUID+STAT_ISGID+STAT_ISVTX)); 1261 {$ENDIF} 1262 1263 Result := True; 1264end; 1265 1266function FindProgram(ProgramName, BaseDirectory: string; 1267 WithBaseDirectory: boolean): string; 1268var 1269 Flags: TSearchFileInPathFlags; 1270begin 1271 Result:=''; 1272 if ProgramName='' then exit; 1273 {$IFDEF Unix} 1274 if ProgramName[1]='~' then begin 1275 Delete(ProgramName,1,1); 1276 ProgramName:=GetEnvironmentVariableUTF8('HOME')+ProgramName; 1277 end; 1278 {$ENDIF} 1279 ProgramName:=ResolveDots(ProgramName); 1280 if FilenameIsAbsolute(ProgramName) then begin 1281 if FileExistsCached(ProgramName) then 1282 Result:=ProgramName 1283 else 1284 Result:=''; 1285 exit; 1286 end; 1287 Flags:=[sffFile,sffExecutable]; 1288 if not WithBaseDirectory then 1289 Include(Flags,sffDontSearchInBasePath); 1290 Result:=FileUtil.SearchFileInPath(ProgramName,BaseDirectory, 1291 GetProgramSearchPath,PathSep,Flags); 1292end; 1293 1294function PointToCfgStr(const Point: TPoint): string; 1295begin 1296 Result:=IntToStr(Point.X)+','+IntToStr(Point.Y); 1297end; 1298 1299procedure CfgStrToPoint(const s: string; var Point: TPoint; const DefaultPoint: TPoint); 1300var 1301 p: Integer; 1302begin 1303 p:=1; 1304 while (p<=length(s)) and (s[p]<>',') do inc(p); 1305 Point.X:=StrToIntDef(copy(s,1,p-1),DefaultPoint.X); 1306 Point.Y:=StrToIntDef(copy(s,p+1,length(s)-p),DefaultPoint.Y); 1307end; 1308 1309function GetCurrentUserName: string; 1310begin 1311 Result:=GetEnvironmentVariableUTF8({$IFDEF MSWindows}'USERNAME'{$ELSE}'USER'{$ENDIF}); 1312end; 1313 1314function GetCurrentChangeLog: string; 1315begin 1316 Result:='<'+GetCurrentUserName+'@'+ 1317 {$IF defined(MSWindows) or defined(HASAMIGA)} 1318 GetEnvironmentVariableUTF8('COMPUTERNAME') 1319 {$ELSE} 1320 GetHostname 1321 {$ENDIF} 1322 + '>'; 1323end; 1324 1325function GetProgramSearchPath: string; 1326begin 1327 GetProgramSearchPath := GetEnvironmentVariableUTF8('PATH'); 1328end; 1329 1330function CreateEmptyFile(const Filename: string): boolean; 1331var 1332 fs: TFileStream; 1333begin 1334 Result:=false; 1335 try 1336 InvalidateFileStateCache; 1337 fs:=TFileStream.Create(Filename,fmCreate); 1338 fs.Free; 1339 Result:=true; 1340 except 1341 end; 1342end; 1343 1344function CompareMemStreamText(s1, s2: TMemoryStream): Boolean; 1345// compare text in s2, s2 ignoring line ends 1346var 1347 p1: PChar; 1348 p2: PChar; 1349 Count1: Int64; 1350 Count2: Int64; 1351begin 1352 Result:=false; 1353 if s1.Memory=nil then begin 1354 Result:=s2.Memory=nil; 1355 end else begin 1356 if s2.Memory<>nil then begin 1357 p1:=PChar(s1.Memory); 1358 p2:=PChar(s2.Memory); 1359 Count1:=s1.Size; 1360 Count2:=s2.Size; 1361 repeat 1362 if not (p1^ in [#10,#13]) then begin 1363 // p1 has normal char 1364 if p1^=p2^ then begin 1365 inc(p1); 1366 dec(Count1); 1367 inc(p2); 1368 dec(Count2); 1369 end else begin 1370 exit(false); 1371 end; 1372 end else begin 1373 // p1 has a newline 1374 if (p2^ in [#10,#13]) then begin 1375 // p2 has a newline 1376 if (Count1>1) and (p1[1] in [#10,#13]) and (p1[0]<>p1[1]) then 1377 begin 1378 inc(p1,2); 1379 dec(Count1,2); 1380 end else begin 1381 inc(p1); 1382 dec(Count1); 1383 end; 1384 if (Count2>1) and (p2[1] in [#10,#13]) and (p2[0]<>p2[1]) then 1385 begin 1386 inc(p2,2); 1387 dec(Count2,2); 1388 end else begin 1389 inc(p2); 1390 dec(Count2); 1391 end; 1392 end else begin 1393 // p1 has newline, p2 not 1394 exit(false); 1395 end; 1396 end; 1397 if Count1=0 then begin 1398 Result:=Count2=0; 1399 exit; 1400 end else if Count2=0 then begin 1401 exit(false); 1402 end; 1403 until false; 1404 end; 1405 end; 1406end; 1407 1408function CheckGroupItemChecked(CheckGroup: TCheckGroup; const Caption: string): Boolean; 1409begin 1410 Result := CheckGroup.Checked[CheckGroup.Items.IndexOf(Caption)]; 1411end; 1412 1413end. 1414 1415