1{%MainUnit fileutil.pas} 2{****************************************************************************** 3 Fileutil 4 ****************************************************************************** 5 6 ***************************************************************************** 7 This file is part of LazUtils. 8 9 See the file COPYING.modifiedLGPL.txt, included in this distribution, 10 for details about the license. 11 ***************************************************************************** 12} 13 14// ToDo: For ExpandUNCFileNameUTF8 15// 16// Don't convert to and from Sys, because this RTL routines 17// simply work in simple string operations, without calling native 18// APIs which would really require Ansi 19// 20// The Ansi conversion just ruins Unicode strings 21// 22// See bug http://bugs.freepascal.org/view.php?id=20229 23// It needs fixing like we did for LazFileUtils.ExpandFileNameUtf8(Filename) on Windows 24 25function ExpandUNCFileNameUTF8(const FileName: string): string; 26begin 27 Result:=SysUtils.ExpandUNCFileName(Filename); 28end; 29 30function FileSize(const Filename: string): int64; 31begin 32 Result := FileSizeUtf8(FileName); 33end; 34 35function ComparePhysicalFilenames(const Filename1, Filename2: string): integer; 36var 37 File1: String; 38 File2: String; 39begin 40 File1:=GetPhysicalFilename(Filename1,pfeOriginal); 41 File2:=GetPhysicalFilename(Filename2,pfeOriginal); 42 Result:=LazFileUtils.CompareFilenames(File1,File2); 43end; 44 45function CompareFilenames(Filename1: PChar; Len1: integer; 46 Filename2: PChar; Len2: integer; ResolveLinks: boolean): integer; 47var 48 File1: string; 49 File2: string; 50 {$IFNDEF NotLiteralFilenames} 51 i: Integer; 52 {$ENDIF} 53begin 54 if (Len1=0) or (Len2=0) then begin 55 Result:=Len1-Len2; 56 exit; 57 end; 58 if ResolveLinks then begin 59 SetLength(File1{%H-},Len1); 60 System.Move(Filename1^,File1[1],Len1); 61 SetLength(File2{%H-},Len2); 62 System.Move(Filename2^,File2[1],Len2); 63 if ResolveLinks then 64 Result:=ComparePhysicalFilenames(File1,File2) 65 else 66 Result:=LazFileUtils.CompareFilenames(File1,File2); 67 end else begin 68 {$IFDEF NotLiteralFilenames} 69 SetLength(File1,Len1); 70 System.Move(Filename1^,File1[1],Len1); 71 SetLength(File2,Len2); 72 System.Move(Filename2^,File2[1],Len2); 73 Result:=LazFileUtils.CompareFilenames(File1,File2); 74 {$ELSE} 75 Result:=0; 76 i:=0; 77 while (Result=0) and ((i<Len1) and (i<Len2)) do begin 78 Result:=Ord(Filename1[i]) 79 -Ord(Filename2[i]); 80 Inc(i); 81 end; 82 if Result=0 Then 83 Result:=Len1-Len2; 84 {$ENDIF} 85 end; 86end; 87 88function FilenameHasPascalExt(const Filename: string): boolean; 89var 90 i, FnPos: Integer; 91 FnExt: String; 92begin 93 FnPos := length(Filename); 94 while (FnPos>=1) and (Filename[FnPos]<>'.') do dec(FnPos); 95 if FnPos < 1 then 96 exit(false); // no extension in filename 97 FnExt := Copy(Filename, FnPos, length(FileName)); 98 for i:=Low(PascalFileExt) to High(PascalFileExt) do 99 if CompareText(FnExt,PascalFileExt[i])=0 then 100 exit(true); 101 Result:=false; 102end; 103 104function DeleteDirectory(const DirectoryName: string; OnlyChildren: boolean): boolean; 105const 106 //Don't follow symlinks on *nix, just delete them 107 DeleteMask = faAnyFile {$ifdef unix} or faSymLink{%H-} {$endif unix}; 108var 109 FileInfo: TSearchRec; 110 CurSrcDir: String; 111 CurFilename: String; 112begin 113 Result:=false; 114 CurSrcDir:=CleanAndExpandDirectory(DirectoryName); 115 if FindFirstUTF8(CurSrcDir+GetAllFilesMask,DeleteMask,FileInfo)=0 then begin 116 repeat 117 // check if special file 118 if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') then 119 continue; 120 CurFilename:=CurSrcDir+FileInfo.Name; 121 if ((FileInfo.Attr and faDirectory)>0) 122 {$ifdef unix} and ((FileInfo.Attr and faSymLink{%H-})=0) {$endif unix} then begin 123 if not DeleteDirectory(CurFilename,false) then exit; 124 end else begin 125 if not DeleteFileUTF8(CurFilename) then exit; 126 end; 127 until FindNextUTF8(FileInfo)<>0; 128 end; 129 FindCloseUTF8(FileInfo); 130 if (not OnlyChildren) and (not RemoveDirUTF8(CurSrcDir)) then exit; 131 Result:=true; 132end; 133 134function ProgramDirectory: string; 135var 136 Flags: TSearchFileInPathFlags; 137begin 138 Result:=ParamStrUTF8(0); 139 if ExtractFilePath(Result)='' then begin 140 // program was started via PATH 141 {$IFDEF WINDOWS} 142 Flags:=[]; 143 {$ELSE} 144 Flags:=[sffDontSearchInBasePath]; 145 {$ENDIF} 146 Result:=SearchFileInPath(Result,'',GetEnvironmentVariableUTF8('PATH'),PathSeparator,Flags); 147 end; 148 // resolve links 149 Result:=GetPhysicalFilename(Result,pfeOriginal); 150 // extract file path and expand to full name 151 Result:=ExpandFileNameUTF8(ExtractFilePath(Result)); 152end; 153 154function ProgramDirectoryWithBundle: string; 155const 156 BundlePostFix='.app/Contents/MacOS'; 157begin 158 Result:=ProgramDirectory; 159 if (RightStr(ChompPathDelim(Result),Length(BundlePostFix))=BundlePostFix) then 160 Result:=ExtractFilePath(LeftStr(Result,Length(Result)-Length(BundlePostFix))); 161end; 162 163function FileIsInPath(const Filename, Path: string): boolean; 164var 165 ExpFile: String; 166 ExpPath: String; 167 l: integer; 168begin 169 ExpFile:=CleanAndExpandFilename(Filename); 170 ExpPath:=CleanAndExpandDirectory(Path); 171 l:=length(ExpPath); 172 Result:=(l>0) and (length(ExpFile)>l) and (ExpFile[l] in AllowDirectorySeparators) 173 and (CompareFilenames(ExpPath,LeftStr(ExpFile,l))=0); 174end; 175 176function FileIsInDirectory(const Filename, Directory: string): boolean; 177var 178 ExpFile: String; 179 ExpDir: String; 180 LenFile: Integer; 181 LenDir: Integer; 182 p: LongInt; 183begin 184 ExpFile:=CleanAndExpandFilename(Filename); 185 ExpDir:=CleanAndExpandDirectory(Directory); 186 LenFile:=length(ExpFile); 187 LenDir:=length(ExpDir); 188 p:=LenFile; 189 while (p>0) and not (ExpFile[p] in AllowDirectorySeparators) do dec(p); 190 Result:=(p=LenDir) and (p<LenFile) 191 and (CompareFilenames(ExpDir,LeftStr(ExpFile,p))=0); 192end; 193 194function ExtractFileNameWithoutExt(const AFilename: string): string; 195begin 196 Result:=LazFileUtils.ExtractFileNameWithoutExt(AFilename); 197end; 198 199function CreateAbsoluteSearchPath(const SearchPath, BaseDirectory: string): string; 200begin 201 Result:=LazFileUtils.CreateAbsoluteSearchPath(SearchPath, BaseDirectory); 202end; 203 204function CreateAbsolutePath(const Filename, BaseDirectory: string): string; 205begin 206 Result:=LazFileUtils.CreateAbsolutePath(Filename, BaseDirectory); 207end; 208 209function CopyFile(const SrcFilename, DestFilename: string; 210 Flags: TCopyFileFlags; ExceptionOnError: Boolean): boolean; 211var 212 SrcHandle: THandle; 213 DestHandle: THandle; 214 Buffer: array[1..4096] of byte; 215 ReadCount, WriteCount, TryCount: LongInt; 216begin 217 Result := False; 218 // check overwrite 219 if (not (cffOverwriteFile in Flags)) and FileExistsUTF8(DestFileName) then 220 exit; 221 // check directory 222 if (cffCreateDestDirectory in Flags) 223 and (not DirectoryExistsUTF8(ExtractFilePath(DestFileName))) 224 and (not ForceDirectoriesUTF8(ExtractFilePath(DestFileName))) then 225 exit; 226 TryCount := 0; 227 While TryCount <> 3 Do Begin 228 SrcHandle := FileOpenUTF8(SrcFilename, fmOpenRead or fmShareDenyWrite); 229 if THandle(SrcHandle)=feInvalidHandle then Begin 230 Inc(TryCount); 231 Sleep(10); 232 End 233 Else Begin 234 TryCount := 0; 235 Break; 236 End; 237 End; 238 If TryCount > 0 Then 239 begin 240 if ExceptionOnError then 241 raise EFOpenError.CreateFmt({SFOpenError}'Unable to open file "%s"', [SrcFilename]) 242 else 243 exit; 244 end; 245 try 246 DestHandle := FileCreateUTF8(DestFileName); 247 if (THandle(DestHandle)=feInvalidHandle) then 248 begin 249 if ExceptionOnError then 250 raise EFCreateError.CreateFmt({SFCreateError}'Unable to create file "%s"',[DestFileName]) 251 else 252 Exit; 253 end; 254 try 255 repeat 256 ReadCount:=FileRead(SrcHandle,Buffer[1],High(Buffer)); 257 if ReadCount<=0 then break; 258 WriteCount:=FileWrite(DestHandle,Buffer[1],ReadCount); 259 if WriteCount<ReadCount then 260 begin 261 if ExceptionOnError then 262 raise EWriteError.CreateFmt({SFCreateError}'Unable to write to file "%s"',[DestFileName]) 263 else 264 Exit; 265 end; 266 until false; 267 finally 268 FileClose(DestHandle); 269 end; 270 if (cffPreserveTime in Flags) then 271 FileSetDateUTF8(DestFilename, FileGetDate(SrcHandle)); 272 Result := True; 273 finally 274 FileClose(SrcHandle); 275 end; 276end; 277 278function CopyFile(const SrcFilename, DestFilename: string; 279 PreserveTime: boolean; ExceptionOnError: Boolean): boolean; 280// Flags parameter can be used for the same thing. 281var 282 Flags: TCopyFileFlags; 283begin 284 if PreserveTime then 285 Flags:=[cffPreserveTime, cffOverwriteFile] 286 else 287 Flags:=[cffOverwriteFile]; 288 Result := CopyFile(SrcFilename, DestFilename, Flags, ExceptionOnError); 289end; 290 291{ TCopyDirTree for CopyDirTree function } 292type 293 TCopyDirTree = class(TFileSearcher) 294 private 295 FSourceDir: string; 296 FTargetDir: string; 297 FFlags: TCopyFileFlags; 298 FCopyFailedCount: Integer; 299 protected 300 procedure DoFileFound; override; 301 //procedure DoDirectoryFound; override; 302 end; 303 304procedure TCopyDirTree.DoFileFound; 305var 306 NewLoc: string; 307begin 308 // ToDo: make sure StringReplace works in all situations ! 309 NewLoc:=StringReplace(FileName, FSourceDir, FTargetDir, []); 310 if not CopyFile(FileName, NewLoc, FFlags) then 311 Inc(FCopyFailedCount); 312end; 313{ 314procedure TCopyDirTree.DoDirectoryFound; 315begin 316 // Directory is already created by the cffCreateDestDirectory flag. 317end; 318} 319function CopyDirTree(const SourceDir, TargetDir: string; Flags: TCopyFileFlags=[]): Boolean; 320var 321 Searcher: TCopyDirTree; 322begin 323 Result:=False; 324 Searcher:=TCopyDirTree.Create; 325 try 326 // Destination directories are always created. User setting has no effect! 327 Searcher.FFlags:=Flags+[cffCreateDestDirectory]; 328 Searcher.FCopyFailedCount:=0; 329 Searcher.FSourceDir:=TrimFilename(SetDirSeparators(SourceDir)); 330 Searcher.FTargetDir:=TrimFilename(SetDirSeparators(TargetDir)); 331 332 // Don't even try to copy to a subdirectory of SourceDir. 333 //append a pathedelim, otherwise CopyDirTree('/home/user/foo','/home/user/foobar') will fail at this point. Issue #0038644 334 {$ifdef CaseInsensitiveFilenames} 335 if AnsiStartsText(AppendPathDelim(Searcher.FSourceDir), AppendPathDelim(Searcher.FTargetDir)) then Exit; 336 {$ELSE} 337 if AnsiStartsStr(AppendPathDelim(Searcher.FSourceDir), AppendPathDelim(Searcher.FTargetDir)) then Exit; 338 {$ENDIF} 339 Searcher.Search(SourceDir); 340 Result:=Searcher.FCopyFailedCount=0; 341 finally 342 Searcher.Free; 343 end; 344end; 345 346function GetAllFilesMask: string; 347begin 348 {$IFDEF WINDOWS} 349 Result:='*.*'; 350 {$ELSE} 351 Result:='*'; 352 {$ENDIF} 353end; 354 355function GetExeExt: string; 356begin 357 {$IFDEF WINDOWS} 358 Result:='.exe'; 359 {$ELSE} 360 Result:=''; 361 {$ENDIF} 362end; 363 364function ReadFileToString(const Filename: string): string; 365// Read and return the contents of a text file in one slurp. 366// Note: FileSize() returns 0 for virtual files at least in Unix like systems. 367// Then use different ways to read contents, eg. TStringList.LoadFromFile(); 368var 369 SrcHandle: THandle; 370 ReadCount: LongInt; 371 s: String; 372begin 373 Result := ''; 374 s:=''; 375 try 376 Setlength(s, FileSize(Filename)); 377 if s='' then exit; 378 SrcHandle := FileOpenUTF8(Filename, fmOpenRead or fmShareDenyWrite); 379 if THandle(SrcHandle)=feInvalidHandle then 380 exit; 381 try 382 ReadCount:=FileRead(SrcHandle,s[1],length(s)); 383 if ReadCount<length(s) then 384 exit; 385 finally 386 FileClose(SrcHandle); 387 end; 388 Result:=s; 389 except 390 // ignore errors, Result string will be empty 391 end; 392end; 393 394function SearchFileInPath(const Filename, BasePath: string; SearchPath: string; 395 const Delimiter: string; Flags: TSearchFileInPathFlags): string; 396var 397 p, StartPos, l, QuoteStart: integer; 398 CurPath, Base: string; 399begin 400//debugln('[SearchFileInPath] Filename="',Filename,'" BasePath="',BasePath,'" SearchPath="',SearchPath,'" Delimiter="',Delimiter,'"'); 401 if (Filename='') then begin 402 Result:=''; 403 exit; 404 end; 405 // check if filename absolute 406 if FilenameIsAbsolute(Filename) then begin 407 if FileExistsUTF8(Filename) then begin 408 Result:=CleanAndExpandFilename(Filename); 409 exit; 410 end else begin 411 Result:=''; 412 exit; 413 end; 414 end; 415 Base:=CleanAndExpandDirectory(BasePath); 416 // search in current directory 417 if (not (sffDontSearchInBasePath in Flags)) and FileExistsUTF8(Base+Filename) then 418 exit(CleanAndExpandFilename(Base+Filename)); 419 // search in search path 420 StartPos:=1; 421 l:=length(SearchPath); 422 while StartPos<=l do begin 423 p:=StartPos; 424 while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do 425 begin 426 if (SearchPath[p]='"') and (sffDequoteSearchPath in Flags) then 427 begin 428 // For example: Windows allows set path=C:\"a;b c"\d;%path% 429 QuoteStart:=p; 430 repeat 431 inc(p); 432 until (p>l) or (SearchPath[p]='"'); 433 if p<=l then 434 begin 435 system.delete(SearchPath,p,1); 436 system.delete(SearchPath,QuoteStart,1); 437 dec(l,2); 438 dec(p,2); 439 end; 440 end; 441 inc(p); 442 end; 443 CurPath:=copy(SearchPath,StartPos,p-StartPos); 444 CurPath:=TrimFilename(CurPath); 445 StartPos:=p+1; 446 if CurPath='' then continue; 447 if not FilenameIsAbsolute(CurPath) then 448 CurPath:=Base+CurPath; 449 Result:=CleanAndExpandFilename(AppendPathDelim(CurPath)+Filename); 450 if not FileExistsUTF8(Result) then 451 continue; 452 if (sffFile in Flags) and DirectoryExistsUTF8(Result) then 453 continue; 454 if (sffExecutable in Flags) and not FileIsExecutable(Result) then 455 continue; 456 exit; 457 end; 458 Result:=''; 459end; 460 461function SearchAllFilesInPath(const Filename, BasePath, SearchPath, 462 Delimiter: string; Flags: TSearchFileInPathFlags): TStrings; 463 464 procedure Add(NewFilename: string); 465 var 466 i: Integer; 467 begin 468 NewFilename:=TrimFilename(NewFilename); 469 if Result<>nil then 470 for i:=0 to Result.Count-1 do 471 if CompareFilenames(Result[i],NewFilename)=0 then exit; 472 if not FileExistsUTF8(NewFilename) then 473 exit; 474 if (sffFile in Flags) and DirectoryExistsUTF8(NewFilename) then 475 exit; 476 if (sffExecutable in Flags) and not FileIsExecutable(NewFilename) then 477 exit; 478 if Result=nil then 479 Result:=TStringList.Create; 480 Result.Add(NewFilename); 481 end; 482 483var 484 p, StartPos, l: integer; 485 CurPath, Base: string; 486begin 487 Result:=nil; 488 if (Filename='') then exit; 489 // check if filename absolute 490 if FilenameIsAbsolute(Filename) then begin 491 Add(CleanAndExpandFilename(Filename)); 492 exit; 493 end; 494 Base:=CleanAndExpandDirectory(BasePath); 495 // search in current directory 496 if (not (sffDontSearchInBasePath in Flags)) then begin 497 Add(CleanAndExpandFilename(Base+Filename)); 498 end; 499 // search in search path 500 StartPos:=1; 501 l:=length(SearchPath); 502 while StartPos<=l do begin 503 p:=StartPos; 504 while (p<=l) and (pos(SearchPath[p],Delimiter)<1) do inc(p); 505 CurPath:=TrimFilename(copy(SearchPath,StartPos,p-StartPos)); 506 if CurPath<>'' then begin 507 if not FilenameIsAbsolute(CurPath) then 508 CurPath:=Base+CurPath; 509 Add(CleanAndExpandFilename(AppendPathDelim(CurPath)+Filename)); 510 end; 511 StartPos:=p+1; 512 end; 513end; 514 515function FindDiskFilename(const Filename: string): string; 516// Searches for the filename case on disk. 517// The file must exist. 518// For example: 519// If Filename='file' and there is only a 'File' then 'File' will be returned. 520var 521 StartPos: Integer; 522 EndPos: LongInt; 523 FileInfo: TSearchRec; 524 CurDir: String; 525 CurFile: String; 526 AliasFile: String; 527 Ambiguous: Boolean; 528begin 529 Result:=Filename; 530 if not FileExistsUTF8(Filename) then exit; 531 //Sanitize result first (otherwise result can contain things like foo/\bar on Windows) 532 Result := ResolveDots(Result); 533 // check every directory and filename 534 StartPos:=1; 535 {$IFDEF WINDOWS} 536 // uppercase Drive letter and skip it 537 if ((length(Result)>=2) and (Result[1] in ['A'..'Z','a'..'z']) 538 and (Result[2]=':')) then begin 539 StartPos:=3; 540 if Result[1] in ['a'..'z'] then 541 Result[1]:=upcase(Result[1]); 542 end; 543 {$ENDIF} 544 repeat 545 // skip PathDelim 546 while (StartPos<=length(Result)) and (Result[StartPos] in AllowDirectorySeparators) do 547 inc(StartPos); 548 // find end of filename part 549 EndPos:=StartPos; 550 while (EndPos<=length(Result)) and not (Result[EndPos] in AllowDirectorySeparators) do 551 inc(EndPos); 552 if EndPos>StartPos then begin 553 // search file 554 CurDir:=copy(Result,1,StartPos-1); 555 CurFile:=copy(Result,StartPos,EndPos-StartPos); 556 AliasFile:=''; 557 Ambiguous:=false; 558 if FindFirstUTF8(CurDir+GetAllFilesMask,faAnyFile,FileInfo)=0 then 559 begin 560 repeat 561 // check if special file 562 if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') 563 then 564 continue; 565 if CompareFilenamesIgnoreCase(FileInfo.Name,CurFile)=0 then begin 566 //debugln('FindDiskFilename ',FileInfo.Name,' ',CurFile); 567 if FileInfo.Name=CurFile then begin 568 // file found, has already the correct name 569 AliasFile:=''; 570 break; 571 end else begin 572 // alias found, but has not the correct name 573 if AliasFile='' then begin 574 AliasFile:=FileInfo.Name; 575 end else begin 576 // there are more than one candidate 577 Ambiguous:=true; 578 end; 579 end; 580 end; 581 until FindNextUTF8(FileInfo)<>0; 582 end; 583 FindCloseUTF8(FileInfo); 584 if (AliasFile<>'') and (not Ambiguous) then begin 585 // better filename found -> replace 586 Result:=CurDir+AliasFile+copy(Result,EndPos,length(Result)); 587 end; 588 end; 589 StartPos:=EndPos+1; 590 until StartPos>length(Result); 591end; 592 593function FindDiskFileCaseInsensitive(const Filename: string): string; 594var 595 FileInfo: TSearchRec; 596 ShortFilename: String; 597 CurDir: String; 598begin 599 Result:=''; 600 CurDir:=ExtractFilePath(ResolveDots(Filename)); 601 if FindFirstUTF8(CurDir+GetAllFilesMask,faAnyFile, FileInfo)=0 then begin 602 ShortFilename:=ExtractFilename(Filename); 603 repeat 604 // check if special file 605 if (FileInfo.Name='.') or (FileInfo.Name='..') or (FileInfo.Name='') 606 then 607 continue; 608 if CompareFilenamesIgnoreCase(FileInfo.Name,ShortFilename)<>0 then 609 continue; 610 if FileInfo.Name=ShortFilename then begin 611 // fits exactly 612 //Don't return (unaltered) Filename: otherwise possible changes by ResolveDots get lost 613 Result:=CurDir+FileInfo.Name; 614 break; 615 end; 616 // fits case insensitive 617 Result:=CurDir+FileInfo.Name; 618 until FindNextUTF8(FileInfo)<>0; 619 end; 620 FindCloseUTF8(FileInfo); 621end; 622 623function FindDefaultExecutablePath(const Executable: string; 624 const BaseDir: string): string; 625var 626 Env: string; 627begin 628 if FilenameIsAbsolute(Executable) then begin 629 Result:=Executable; 630 if FileExistsUTF8(Result) then exit; 631 {$IFDEF Windows} 632 if ExtractFileExt(Result)='' then begin 633 Result:=Result+'.exe'; 634 if FileExistsUTF8(Result) then exit; 635 end; 636 {$ENDIF} 637 end else begin 638 Env:=GetEnvironmentVariableUTF8('PATH'); 639 Result:=SearchFileInPath(Executable, BaseDir, Env, PathSeparator, sffFindProgramInPath); 640 if Result<>'' then exit; 641 {$IFDEF Windows} 642 if ExtractFileExt(Executable)='' then begin 643 Result:=SearchFileInPath(Executable+'.exe', BaseDir, Env, PathSeparator, sffFindProgramInPath); 644 if Result<>'' then exit; 645 end; 646 {$ENDIF} 647 end; 648 Result:=''; 649end; 650 651{ TListFileSearcher } 652 653procedure TListFileSearcher.DoFileFound; 654begin 655 FList.Add(FileName); 656 inherited; 657end; 658 659constructor TListFileSearcher.Create(AList: TStrings); 660begin 661 inherited Create; 662 FList := AList; 663end; 664 665procedure FindAllFiles(AList: TStrings; const SearchPath: String; 666 const SearchMask: String; SearchSubDirs: Boolean; DirAttr: Word; 667 MaskSeparator: char; PathSeparator: char); 668var 669 Searcher: TListFileSearcher; 670begin 671 Searcher := TListFileSearcher.Create(AList); 672 Searcher.DirectoryAttribute := DirAttr; 673 Searcher.MaskSeparator := MaskSeparator; 674 Searcher.PathSeparator := PathSeparator; 675 try 676 Searcher.Search(SearchPath, SearchMask, SearchSubDirs); 677 finally 678 Searcher.Free; 679 end; 680end; 681 682function FindAllFiles(const SearchPath: String; const SearchMask: String; 683 SearchSubDirs: Boolean; DirAttr: Word; 684 MaskSeparator: char; PathSeparator: char): TStringList; 685begin 686 Result := TStringList.Create; 687 FindAllFiles(Result, SearchPath, SearchMask, SearchSubDirs, DirAttr, MaskSeparator, PathSeparator); 688end; 689 690{ TListDirectoriesSearcher } 691 692constructor TListDirectoriesSearcher.Create(AList: TStrings); 693begin 694 inherited Create; 695 FDirectoriesList := AList; 696end; 697 698procedure TListDirectoriesSearcher.DoDirectoryFound; 699begin 700 FDirectoriesList.Add(FileName); 701 inherited; 702end; 703 704function FindAllDirectories(const SearchPath : string; 705 SearchSubDirs: Boolean; PathSeparator: char): TStringList; 706begin 707 Result := TStringList.Create; 708 FindAllDirectories(Result, SearchPath, SearchSubDirs, PathSeparator); 709end; 710 711procedure FindAllDirectories(AList: TStrings; const SearchPath: String; 712 SearchSubDirs: Boolean; PathSeparator: char); 713var 714 Searcher :TFileSearcher; 715begin 716 Assert(AList <> nil); 717 Searcher := TListDirectoriesSearcher.Create(AList); 718 Searcher.PathSeparator := PathSeparator; 719 try 720 Searcher.Search(SearchPath, AllFilesMask, SearchSubDirs); 721 finally 722 Searcher.Free; 723 end; 724end; 725 726{ TFileIterator } 727 728function TFileIterator.GetFileName: String; 729begin 730 Result := FPath + FFileInfo.Name; 731end; 732 733procedure TFileIterator.Stop; 734begin 735 FSearching := False; 736end; 737 738function TFileIterator.IsDirectory: Boolean; 739begin 740 Result := (FFileInfo.Attr and faDirectory) <> 0; 741end; 742 743{ TFileSearcher } 744 745procedure TFileSearcher.RaiseSearchingError; 746begin 747 raise Exception.Create('The file searcher is already searching!'); 748end; 749 750procedure TFileSearcher.DoDirectoryEnter; 751begin 752 if Assigned(FonDirectoryEnter) then FOnDirectoryEnter(Self); 753end; 754 755procedure TFileSearcher.DoDirectoryFound; 756begin 757 if Assigned(FOnDirectoryFound) then OnDirectoryFound(Self); 758end; 759 760procedure TFileSearcher.DoFileFound; 761begin 762 if Assigned(FOnFileFound) then OnFileFound(Self); 763end; 764 765constructor TFileSearcher.Create; 766begin 767 inherited Create; 768 FMaskSeparator := ';'; 769 FPathSeparator := ';'; 770 FFollowSymLink := True; 771 FFileAttribute := faAnyFile; 772 FDirectoryAttribute := faDirectory; 773 FSearching := False; 774end; 775 776procedure TFileSearcher.Search(const ASearchPath: String; const ASearchMask: String; 777 ASearchSubDirs: Boolean; CaseSensitive: Boolean = False); 778var 779 MaskList: TMaskList; 780 SearchDirectories: TStringList; 781 782 procedure DoSearch(const APath: String; const ALevel: Integer); 783 var 784 P: String; 785 PathInfo: TSearchRec; 786 begin 787 P := APath + AllDirectoryEntriesMask; 788 789 if FindFirstUTF8(P, FileAttribute, PathInfo) = 0 then 790 try 791 repeat 792 // skip special files 793 if (PathInfo.Name = '.') or (PathInfo.Name = '..') or 794 (PathInfo.Name = '') then Continue; 795 // Deal with both files and directories 796 if (PathInfo.Attr and faDirectory) = 0 then 797 begin // File 798 {$IFDEF Windows} 799 if (MaskList = nil) or MaskList.MatchesWindowsMask(PathInfo.Name) 800 {$ELSE} 801 if (MaskList = nil) or MaskList.Matches(PathInfo.Name) 802 {$ENDIF} 803 then begin 804 FPath := APath; 805 FLevel := ALevel; 806 FFileInfo := PathInfo; 807 DoFileFound; 808 end; 809 end 810 else begin // Directory 811 FPath := APath; 812 FLevel := ALevel; 813 FFileInfo := PathInfo; 814 DoDirectoryFound; 815 end; 816 817 until (FindNextUTF8(PathInfo) <> 0) or not FSearching; 818 finally 819 FindCloseUTF8(PathInfo); 820 end; 821 822 if ASearchSubDirs or (ALevel > 0) then 823 // search recursively in directories 824 if FindFirstUTF8(P, DirectoryAttribute, PathInfo) = 0 then 825 try 826 repeat 827 if (PathInfo.Name = '.') or (PathInfo.Name = '..') or 828 (PathInfo.Name = '') or ((PathInfo.Attr and faDirectory) = 0) or 829 (not FFollowSymLink and FileIsSymlink(APath + PathInfo.Name)) 830 then Continue; 831 832 FPath := APath; 833 FLevel := ALevel; 834 FFileInfo := PathInfo; 835 DoDirectoryEnter; 836 if not FSearching then Break; 837 838 DoSearch(AppendPathDelim(APath + PathInfo.Name), Succ(ALevel)); 839 840 until (FindNextUTF8(PathInfo) <> 0); 841 finally 842 FindCloseUTF8(PathInfo); 843 end; 844 end; 845 846var 847 p1, p2: SizeInt; 848 i: Integer; 849 Dir: String; 850 OtherDir: String; 851 MaskOptions: TMaskOptions; 852begin 853 if FSearching then RaiseSearchingError; 854 if CaseSensitive then 855 MaskOptions := [moCaseSensitive] 856 else 857 MaskOptions := []; 858 MaskList := TMaskList.Create(ASearchMask, FMaskSeparator, MaskOptions); 859 // empty mask = all files mask 860 if MaskList.Count = 0 then 861 FreeAndNil(MaskList); 862 863 FSearching := True; 864 SearchDirectories:=TStringList.Create; 865 try 866 p1:=1; 867 while p1<=Length(ASearchPath) do 868 begin 869 p2:=PosEx(FPathSeparator,ASearchPath,p1); 870 if p2<1 then 871 p2:=length(ASearchPath)+1; 872 Dir:=ResolveDots(Copy(ASearchPath,p1,p2-p1)); 873 p1:=p2+1; 874 if Dir='' then continue; 875 Dir:=ChompPathDelim(Dir); 876 for i:=SearchDirectories.Count-1 downto 0 do 877 begin 878 OtherDir:=SearchDirectories[i]; 879 if (CompareFilenames(Dir,OtherDir)=0) 880 or (ASearchSubDirs and (FileIsInPath(Dir,OtherDir))) then 881 begin 882 // directory Dir is already searched 883 Dir:=''; 884 break; 885 end; 886 if ASearchSubDirs and FileIsInPath(OtherDir,Dir) then 887 // directory Dir includes the old directory => delete 888 SearchDirectories.Delete(i); 889 end; 890 if Dir<>'' then 891 SearchDirectories.Add(Dir); 892 end; 893 //Search currentdirectory if ASearchPath = '' 894 if (SearchDirectories.Count=0) then 895 DoSearch('',0) 896 else 897 begin 898 for i:=0 to SearchDirectories.Count-1 do 899 DoSearch(AppendPathDelim(SearchDirectories[i]), 0); 900 end; 901 finally 902 SearchDirectories.Free; 903 FSearching := False; 904 MaskList.Free; 905 end; 906end; 907 908