(*----------------------------------------
ファイルとディレクトリを列挙するユニット
マルチスレッド対応を見越してrecordメソッドで実装する
2013/01/17(木)
・  作成
2013/01/31(木)
・  Loop処理に切り替えて、さらに汎用的にした。
・  列挙指定にliDirectoryFileを用意した
//----------------------------------------*)
unit FileDirectoryList;

interface

uses
  Types,
  SysUtils,
uses_end;

type
  TFileDirectoryList = record

  public
    type TListItem = (liFile, liDirectory, liFileDirectory, liDirectoryFile);

    type TFilterPredicate = reference to
      function(const Path: string; const SearchRec: TSearchRec): Boolean;

    type TItemAddControl = reference to
     procedure(const Path: string; const SearchRec: TSearchRec;
     var ItemAdd: Boolean; var Stop: Boolean);

    type TRecursiveCallControl = reference to
     procedure(const Path: string; const SearchRec: TSearchRec;
     var Skip: Boolean; var Stop: Boolean);

    type TLoopProcedure = reference to
     procedure(const Path: string; const SearchRec: TSearchRec;
     var Stop: Boolean);

    function CheckAttr(SearchRec: TSearchRec;
      Attribute: Integer): Boolean;

    function IsDirectory(SearchRec: TSearchRec): Boolean;
    function IsArchive(SearchRec: TSearchRec): Boolean;
    function IsHidden(SearchRec: TSearchRec): Boolean;
    function IsReadOnly(SearchRec: TSearchRec): Boolean;
    function IsSysFile(SearchRec: TSearchRec): Boolean;

    type TSearchOption = (soTopDirectoryOnly, soAllDirectories);

    function GetFiles(Path: String;
     SearchOption: TSearchOption = soTopDirectoryOnly;
     FilterPredicate: TFilterPredicate = nil): TStringDynArray;
    function GetDirectories(Path: String;
     SearchOption: TSearchOption = soTopDirectoryOnly;
     FilterPredicate: TFilterPredicate = nil): TStringDynArray;
    function GetFileSystemEntries(Path: String;
     SearchOption: TSearchOption = soTopDirectoryOnly;
     FilterPredicate: TFilterPredicate = nil): TStringDynArray;

    function GetFilesDirectoriesTopDirectoryOnly(Path: String;
     ListItem: TListItem;
     ItemAddControl: TItemAddControl = nil): TStringDynArray; overload;

    function GetFilesDirectoriesAllDirectories(Path: string;
     ListItem: TListItem; ItemAddControl: TItemAddControl = nil;
     RecursiveCallControl: TRecursiveCallControl = nil): TStringDynArray;

    function LoopTopDirectoryOnly(Path: String; ListItem: TListItem;
      LoopProcedure: TLoopProcedure): Boolean;

    function LoopAllDirectories(Path: String; ListItem: TListItem;
      LoopProcedure: TLoopProcedure;
      RecursiveCallControl: TRecursiveCallControl = nil): Boolean;
  private

    function _GetFilesDirectoriesTopDirectoryOnly(Path: String;
     ListItem: TListItem;
     FilterPredicate: TFilterPredicate): TStringDynArray;

    function _GetFilesDirectoriesAllDirectories(Path: string;
     ListItem: TListItem;
     FilterPredicate: TFilterPredicate): TStringDynArray;

    procedure _ResultArrayItemAdd(ItemAddControl: TItemAddControl;
      var Result: TStringDynArray; Path: String; SearchRec: TSearchRec;
      var Stop: Boolean);

  end;

implementation

{ TFileDirectoryList }


{---------------------------------------
    外部公開用のメソッド
    GetFiles/GetDirectories/GetFileSystemEntries
機能:   
備考:   
履歴:   
2013/01/18
・  作成
}//(*-----------------------------------
function TFileDirectoryList.GetFiles(Path: string;
 SearchOption: TSearchOption;
 FilterPredicate: TFilterPredicate): TStringDynArray;
begin
  case SearchOption of
    soTopDirectoryOnly:
    begin
      Result := _GetFilesDirectoriesTopDirectoryOnly(Path, liFile, FilterPredicate);
    end;
    soAllDirectories:
    begin
      Result := _GetFilesDirectoriesAllDirectories(Path, liFile, FilterPredicate);
    end;
  end;
end;

function TFileDirectoryList.GetDirectories(Path: String;
 SearchOption: TSearchOption = soTopDirectoryOnly;
 FilterPredicate: TFilterPredicate = nil): TStringDynArray;
begin
  case SearchOption of
    soTopDirectoryOnly:
    begin
      Result := _GetFilesDirectoriesTopDirectoryOnly(Path, liDirectory, FilterPredicate);
    end;
    soAllDirectories:
    begin
      Result := _GetFilesDirectoriesAllDirectories(Path, liDirectory, FilterPredicate);
    end;
  end;
end;

function TFileDirectoryList.GetFileSystemEntries(Path: String;
 SearchOption: TSearchOption = soTopDirectoryOnly;
 FilterPredicate: TFilterPredicate = nil): TStringDynArray;
begin
  case SearchOption of
    soTopDirectoryOnly:
    begin
      Result := _GetFilesDirectoriesTopDirectoryOnly(Path, liFileDirectory, FilterPredicate);
    end;
    soAllDirectories:
    begin
      Result := _GetFilesDirectoriesAllDirectories(Path, liFileDirectory, FilterPredicate);
    end;
  end;
end;
//------------------------------------*)


{---------------------------------------
    属性
機能:   
備考:
SysUtils.pasより
  faInvalid     = -1;
  faReadOnly    = $00000001;
  faHidden      = $00000002 platform; // only a convention on POSIX
  faSysFile     = $00000004 platform; // on POSIX system files are not regular files and not directories
  faVolumeID    = $00000008 platform deprecated;  // not used in Win32
  faDirectory   = $00000010;
  faArchive     = $00000020 platform;
  faNormal      = $00000080;
  faTemporary   = $00000100 platform;
  faSymLink     = $00000400 platform; // Only available on Vista and above
  faCompressed  = $00000800 platform;
  faEncrypted   = $00004000 platform;
  faVirtual     = $00010000 platform;
  faAnyFile     = $000001FF;
これらのファイル属性を調べる事ができる

              // 16進数    10進数   2進数
  faReadOnly  = $00000001; // 1;    000001
  faHidden    = $00000002; // 2;    000010
  faSysFile   = $00000004; // 4;    000100
  faVolumeID  = $00000008; // 8;    001000
  faDirectory = $00000010; // 16;   010000
  faArchive   = $00000020; // 32;   100000
                           // 48;   110000
SearchRec.Attrが 48 の場合には
faDirectory属性を持つかどうか調べるには
論理和を行った結果がどちらか大きい方の値と一致するかどうかを判定するとよい。
ソースで書くと次の通り
  if SearchRec.Attr or faDirectory = Max(SearchRec.Attr, faDirectory) then
これと等価な値で計算数が少ない記述は次の通り
  if (SearchRec1.Attr and faDirectory) > 0 then

2進数の所を見て分かる通り
SearchRec.Attrが 48 ならば faDirectory と faArchive の属性を持つ


履歴:   
2013/01/18
・  作成
}//(*-----------------------------------
function TFileDirectoryList.CheckAttr(
 SearchRec: TSearchRec; Attribute: Integer): Boolean;
begin
  Result := (SearchRec.Attr and Attribute) > 0;
end;

function TFileDirectoryList.IsDirectory(SearchRec: TSearchRec): Boolean;
begin
  Result := CheckAttr(SearchRec, faDirectory);
end;

function TFileDirectoryList.IsReadOnly(SearchRec: TSearchRec): Boolean;
begin
  Result := CheckAttr(SearchRec, faReadOnly);
end;

function TFileDirectoryList.IsHidden(SearchRec: TSearchRec): Boolean;
begin
  Result := CheckAttr(SearchRec, faHidden);
end;

function TFileDirectoryList.IsSysFile(SearchRec: TSearchRec): Boolean;
begin
  Result := CheckAttr(SearchRec, faSysFile);
end;

function TFileDirectoryList.IsArchive(SearchRec: TSearchRec): Boolean;
begin
  Result := CheckAttr(SearchRec, faArchive);
end;


//------------------------------------*)


{---------------------------------------
    TopDirectory列挙用のメソッド
機能:   
備考:   
履歴:
2013/01/18
・  作成
}//(*-----------------------------------

//指定無名関数をループさせる処理
//全てのループがOKならTrueを返す
function TFileDirectoryList.LoopTopDirectoryOnly(Path: String;
 ListItem: TListItem; LoopProcedure: TLoopProcedure): Boolean;
var
  SearchRec: TSearchRec;
  StopParam: Boolean;
begin
  Result := True;
  Path := ExcludeTrailingPathDelimiter(Path);
  case ListItem of
    liFile:
    begin
      if FindFirst(Path + PathDelim + '*.*', faAnyFile, SearchRec) = 0 then try
      repeat
        if (SearchRec.Name = '.') or (SearchRec.Name = '..') then Continue;
        if IsDirectory(SearchRec) then Continue;
        StopParam := False;
        LoopProcedure(Path, SearchRec, StopParam);
        if StopParam then
        begin
          Result := False;
          Exit;
        end;
      until FindNext(SearchRec) <> 0;
      finally FindClose(SearchRec); end;
    end;

    liDirectory:
    begin
      if FindFirst(Path + PathDelim + '*.*', faAnyFile, SearchRec) = 0 then try
      repeat
        if (SearchRec.Name = '.') or (SearchRec.Name = '..') then Continue;
        if IsDirectory(SearchRec) = False then Continue;
        StopParam := False;
        LoopProcedure(Path, SearchRec, StopParam);
        if StopParam then
        begin
          Result := False;
          Exit;
        end;
      until FindNext(SearchRec) <> 0;
      finally FindClose(SearchRec); end;
    end;

    liFileDirectory:
    begin
      Result := LoopTopDirectoryOnly(Path, liFile, LoopProcedure);
      if Result then
      begin
        Result := LoopTopDirectoryOnly(Path, liDirectory, LoopProcedure);
      end;
      Exit;
    end;

    liDirectoryFile:
    begin
      Result := LoopTopDirectoryOnly(Path, liDirectory, LoopProcedure);
      if Result then
      begin
        Result := LoopTopDirectoryOnly(Path, liFile, LoopProcedure);
      end;
      Exit;
    end;
{----------------------------------------
      Result :=  LoopTopDirectoryOnly(Path, liDirectory, LoopProcedure)
                 and LoopTopDirectoryOnly(Path, liFile, LoopProcedure);
      と書けるはずだけど可読性は低いのでやめておく
//----------------------------------------}

    else
      Assert(False, 'Error:LoopTopDirectoryOnly');
  end;

end;

//Resultの配列に項目を追加する共通処理
procedure TFileDirectoryList._ResultArrayItemAdd(ItemAddControl: TItemAddControl;
 var Result: TStringDynArray; Path: String; SearchRec: TSearchRec; var Stop: Boolean);
var
  ItemAddParam, StopParam: Boolean;
begin
  Stop := False;
  if not Assigned(ItemAddControl) then
  begin
    SetLength(Result, Length(Result) + 1);
    Result[Length(Result)-1] := Path + PathDelim + SearchRec.Name;
  end else
  begin
    ItemAddParam := True;
    StopParam := False;
    ItemAddControl(Path, SearchRec, ItemAddParam, StopParam);
    if ItemAddParam then
    begin
      SetLength(Result, Length(Result) + 1);
      Result[Length(Result)-1] := Path + PathDelim + SearchRec.Name;
    end;
    Stop := StopParam;
  end;
end;

//汎用的な動的配列を返す公開メソッド
function TFileDirectoryList.GetFilesDirectoriesTopDirectoryOnly(Path: String;
 ListItem: TListItem; ItemAddControl: TItemAddControl = nil): TStringDynArray;
var
  Array1: TStringDynArray;
  this: TFileDirectoryList;
begin
  this := Self;
  SetLength(Array1, 0);
  LoopTopDirectoryOnly(Path, ListItem,
    procedure(const Path: string; const SearchRec: TSearchRec;
     var Stop: Boolean)
    begin
      this._ResultArrayItemAdd(ItemAddControl, Array1, Path, SearchRec, Stop);
    end);

  Result := Array1;
end;

//GetFiles/GetDirectories等のためのインターフェース用内部メソッド
function TFileDirectoryList._GetFilesDirectoriesTopDirectoryOnly(Path: String;
 ListItem: TListItem; FilterPredicate: TFilterPredicate): TStringDynArray;
begin
  if Assigned(FilterPredicate) then
  begin
    Result := GetFilesDirectoriesTopDirectoryOnly(Path, ListItem,
      procedure (const Path: string; const SearchRec: TSearchRec;
       var ItemAdd: Boolean; var Stop: Boolean)
      begin
        Stop := False;
        ItemAdd := FilterPredicate(Path, SearchRec);
      end );
  end else
  begin
    Result := GetFilesDirectoriesTopDirectoryOnly(Path, ListItem);
  end;
end;
//------------------------------------*)



{---------------------------------------
    AllDirectories列挙用のメソッド
機能:   
備考:   
履歴:   
2013/01/18
・  作成
}//(*-----------------------------------

//指定無名関数をループさせる処理
//全てのループがOKならTrueを返す
function TFileDirectoryList.LoopAllDirectories(Path: String;
 ListItem: TListItem; LoopProcedure: TLoopProcedure;
 RecursiveCallControl: TRecursiveCallControl = nil): Boolean;

var
  StopFlag: Boolean;

    procedure LoopAllDirectoriesCore(Path: string);
    var
      SearchRec: TSearchRec;
      StopParam: Boolean;
      SkipParam: Boolean;
      DirectoryArray, FileArray: array of TSearchRec;
      I: Integer;
    begin
      if StopFlag then Exit;

      SetLength(DirectoryArray, 0);
      SetLength(FileArray, 0);

      case ListItem of
        liFile:
        begin
          if FindFirst(Path + PathDelim + '*.*', faAnyFile, SearchRec) = 0 then try
          repeat
            if (SearchRec.Name = '.') or (SearchRec.Name = '..') then Continue;
            if IsDirectory(SearchRec) = False then
            begin
              LoopProcedure(Path, SearchRec, StopParam);
              StopFlag := StopParam;
              if StopParam then Exit;
            end else
            begin
              SetLength(DirectoryArray, Length(DirectoryArray) + 1);
              DirectoryArray[Length(DirectoryArray)-1] := SearchRec;
            end;

          until FindNext(SearchRec) <> 0;
          finally FindClose(SearchRec); end;
        end;

        liDirectory:
        begin
          if FindFirst(Path + PathDelim + '*.*', faAnyFile, SearchRec) = 0 then try
          repeat
            if (SearchRec.Name = '.') or (SearchRec.Name = '..') then Continue;
            if IsDirectory(SearchRec) = True then
            begin
              SetLength(DirectoryArray, Length(DirectoryArray) + 1);
              DirectoryArray[Length(DirectoryArray)-1] := SearchRec;
            end;

          until FindNext(SearchRec) <> 0;
          finally FindClose(SearchRec); end;
        end;

        liFileDirectory:
        begin
          if FindFirst(Path + PathDelim + '*.*', faAnyFile, SearchRec) = 0 then try
          repeat
            if (SearchRec.Name = '.') or (SearchRec.Name = '..') then Continue;
            if IsDirectory(SearchRec) = False then
            begin
              LoopProcedure(Path, SearchRec, StopParam);
              StopFlag := StopParam;
              if StopParam then Exit;
            end else
            begin
              SetLength(DirectoryArray, Length(DirectoryArray) + 1);
              DirectoryArray[Length(DirectoryArray)-1] := SearchRec;
            end;

          until FindNext(SearchRec) <> 0;
          finally FindClose(SearchRec); end;
        end;

        liDirectoryFile:
        begin
          if FindFirst(Path + PathDelim + '*.*', faAnyFile, SearchRec) = 0 then try
          repeat
            if (SearchRec.Name = '.') or (SearchRec.Name = '..') then Continue;
            if IsDirectory(SearchRec) = False then
            begin
              SetLength(FileArray, Length(FileArray) + 1);
              FileArray[Length(FileArray)-1] := SearchRec;
            end else
            begin
              SetLength(DirectoryArray, Length(DirectoryArray) + 1);
              DirectoryArray[Length(DirectoryArray)-1] := SearchRec;
            end;

          until FindNext(SearchRec) <> 0;
          finally FindClose(SearchRec); end;
        end;

        else
          Assert(False, 'Error:LoopTopDirectoryOnly');
      end;

      for I := 0 to Length(DirectoryArray) - 1 do
      begin
        SearchRec := DirectoryArray[I];

        case ListItem of
          liDirectory, liFileDirectory, liDirectoryFile:
          begin
            LoopProcedure(Path, SearchRec, StopParam);
            StopFlag := StopParam;
            if StopParam then Exit;
          end;
        end;

        //再帰呼び出し制御
        if Assigned(RecursiveCallControl) then
        begin
          StopParam := False;
          SkipParam := False;
          RecursiveCallControl(Path, SearchRec, SkipParam, StopParam);
          StopFlag := StopParam;
          if SkipParam then Continue;
          if StopParam then Exit;
        end;
        LoopAllDirectoriesCore(Path + PathDelim + SearchRec.Name);
      end;

      //FileArrayが使われる、つまり 1<Length になってループするのは
      //ListItem = liDirectoryFile のみ
      for I := 0 to Length(FileArray) - 1 do
      begin
        SearchRec := FileArray[I];

        LoopProcedure(Path, SearchRec, StopParam);
        StopFlag := StopParam;
        if StopParam then Exit;
      end;
    end;

begin
  Result := False;
  if DirectoryExists(Path) = False then Exit;

  Path := ExcludeTrailingPathDelimiter(Path);
  StopFlag := False;
  LoopAllDirectoriesCore(Path);
  Result := not StopFlag;
end;


//汎用的な動的配列を返す公開メソッド
function TFileDirectoryList.GetFilesDirectoriesAllDirectories(Path: String;
 ListItem: TListItem; ItemAddControl: TItemAddControl = nil;
 RecursiveCallControl: TRecursiveCallControl = nil): TStringDynArray;
var
  Array1: TStringDynArray;
  this: TFileDirectoryList;
begin
  this := Self;
  SetLength(Array1, 0);
  LoopAllDirectories(Path, ListItem,
    procedure(const Path: string; const SearchRec: TSearchRec;
     var Stop: Boolean)
    begin
      this._ResultArrayItemAdd(ItemAddControl, Array1, Path, SearchRec, Stop);
    end,
    RecursiveCallControl);

  Result := Array1;
end;

//GetFiles/GetDirectories等のためのインターフェース用内部メソッド
function TFileDirectoryList._GetFilesDirectoriesAllDirectories(Path: string;
  ListItem: TListItem; FilterPredicate: TFilterPredicate): TStringDynArray;
begin
  if Assigned(FilterPredicate) then
  begin
    Result := GetFilesDirectoriesAllDirectories(Path, ListItem,
      procedure (const Path: string; const SearchRec: TSearchRec;
       var ItemAdd: Boolean; var Stop: Boolean)
      begin
        Stop := False;
        ItemAdd := FilterPredicate(Path, SearchRec);
      end );
  end else
  begin
    Result := GetFilesDirectoriesAllDirectories(Path, ListItem);
  end;
end;
//------------------------------------*)

end.