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