(* FileDir - File and Directory unit
*)

unit FileDir;

interface

uses    classes, windows;

type
	TFileType = (fdReadOnly, fdHidden, fdSysFile, fdArchive, fdNormalFile);
(* この宣言は FileLists でのファイルをリストアップするときにどの属性のファイルを読み出すかを指定するものです。
   ただし、FindFirst などの場合と違い、その属性が付けられたファイルのみをリストアップします。
   例えば fdReadOnly の場合は faReadOnly 属性が付いたもの「のみ」をリストアップします
   （fdReadOnly と fdHidden が両方付けられていたような場合は、fdReadOnly でも fdHidden でもリストアップされます）。
   fdNormalFile は他の全ての属性が付けられて「いない」ファイルをリストアップします。
   多分この方が使いやすいのではないかと思い、そう設定しました。
   なお、faDirectory と faVolumeID は除かれていますが、ディレクトリの場合は DirectoryLists や
   RecusiveDirectoryList で取得します。ボリューム ID は GetVolumeID で取得してください。 *)

	SFileType = set of TFileType;
(* 集合として TFileType 型の要素を扱います。
   単独要素として使用する場合、[fdNormalFile] と言うように指定してください。
   複数指定する場合は、[fdReadOnly, fdHidden, fdSysFile] などと指定してください。
   複数指定された場合は、どれか該当するファイルが全てリストアップされます（or 指定されたのと同じ）。
   なお属性が重複していた（ReadOnly で SysFile の場合など）時でも２重には登録されませんので、
   リストアップされたファイルは「ユニークなもの」として扱えます。 *)

	EnumProc = procedure(const cd : string);
(* RecursiveFileLists と RecursiveDirectoryLists で、いまどのディレクトリを探しているかを表示するために
   この2手続きから本体の手続き（interface で単独宣言する必要があり）を呼び出すための手続き型です。
   これと同じ宣言を呼び出す元のプログラムで宣言する必要があります（それを interface で公開）
   例：本体側で SomeProcedure を呼び出して欲しい場合、interface で以下のように宣言します。
   procedure SomeProcedure(const cd : string);
   そしてそのアドレス（@SomeProcedure）を EnumFileList や RecursiveFileLists や RecursiveDirectoryLists へ渡します。
   この時、メソッドは使えません（どのクラスにも属さない独立の手続きにすること） *)


function  FileByte(filename : string) : longint;
(* filename のファイルのサイズを byte 単位で返す。
   ファイルが見つからない場合には 0 が返されるので、ファイルがない場合でも悪影響を及ぼしません。
   ただし、この関数でファイルが無い場合と 0 バイトのファイルの区別が付きませんので、注意してください。
   ファイルがあるかの確認は FileExists 関数（Delphi）で調べてください。 *)

function  IsDirectory(pathname : string) : boolean;
(* pathname がディレクトリなら true を返す。 *)

procedure FileLists(const path : string; const attr : SFileType; var fl : TStringList);
(* ----- この手続きは過去互換性の為の見に存在します ----- *)
(* この手続きはファイルのリストアップ中に反応が無くなります。そのため、出来るだけ使わないでください。
   この手続きを使うよりも EnumFileLists を使うことをお勧めします。 *)

procedure EnumFileLists(const path : string; const attr : SFileType; var fl : TStringList; const df : EnumProc);
(* path で示されたファイルマスクの attr 属性のファイルの一覧を fl に返す。
   attr は上記宣言の所（SFileType, TFileType）を参照してください。
   fl は呼び出し元で create しておき、free すること。
   fl はこの手続きでは clear しませんので、必要ならこの手続きを呼び出す前に clear しておくこと。
   また、続けて呼び出すことで、複数の拡張子のファイルのリストを作ることが出来ます。
   ファイル名は「絶対パスを含めたファイル名（拡張子含む）」になります。
   df に手続きのアドレスを渡すと、ファイルを一つ検索するたびに df の手続きを呼び出します。
   df に nil を渡すと呼び出しません。（FileLists と同じ動作になる） *)

procedure RecursiveFileLists(const path : string; const attr : SFileType; var fl : TStringList; const df : EnumProc);
(* path で示されたファイルマスクの attr 属性のファイルの一覧を fl に返す。
   再帰的にディレクトリを拾っていく他は FileLists と同等です。
   ディレクトリ名だけの項目はリストアップされません。項目に出てくるものは必ずファイルを指しています。
   df に手続きのアドレスを渡すと、ディレクトリを移るたびに df の手続きを呼び出します。
   df に nil を渡すと呼び出しません。 *)
(* この手続きを呼び出すと、ファイルを検索するたびに動作が止まります。そのため、出来れば使わない方がよいでしょう。
   同等の動作として RecursiveDirectoryLists でディレクトリのリストを作り、各ディレクトリ毎に EnumFileLists を
   呼び出すことで実装できます（またこうすれば Application.ProcessMessage を入れてメッセージ処理が出来る）。 *)

procedure DirectoryLists(path : string; var fl : TStringList);
(* path で示されたディレクトリマスクの一覧を fl に返す。fl には path 自体は含まれません。
   fl は呼び出し元で create しておき、free すること。
   fl はこの手続きでは clear しませんので、必要ならこの手続きを呼び出す前に clear しておくこと。
   また、続けて呼び出すことで、複数のドライブやディレクトリのサブディレクトリリストを作ることが出来ます。
   *)

procedure RecursiveDirectoryLists(const path : string; var fl : TStringList; const df : EnumProc);
(* path で示されたディレクトリマスクの一覧を fl に返す。
   再帰的にディレクトリのリストを作る他は DirectoryLists と同等です。
   df は 上記 RecursiveFileLists を参照してください。 *)


procedure LoadFile(const fn : string; var txt : string);
(* fn のファイル名のファイルを txt に読み込む
   全てのテキストを一気に読み込むので、もし TStringList へ入れたい場合は TSL.text := text（TSL : TStringList）とすればよい *)

procedure SaveFile(const fn : string; txt : string);
(* fn のファイル名のファイルに txt を書き出す
   全てのテキストを一気に書き込みます。SomeText.text（SomeText ： TStringList or TStrings）を txt のパラメータとして手続きを呼び出せば
   一気に出力することが出来ます。
   同名のファイルが既に存在していた場合は、バックアップファイル（拡張子 .bak）を作成してから、ファイルを作成します。 *)

function  ParentPath(pn : string) : string;
(* pn の親パスを返す
   pn に渡す文字列は ExtractFileDir で抜き出した文字列（最期に \ が付かないパス名）を渡す *)


function  FileToTrashBox(const ah : THandle; const fn : string) : boolean;
(* fn のファイル名のファイルをゴミ箱に捨てる。ah はアプリケーションハンドル *)

function  MakeUniqueFileName(const FileName : string; const TargetPath : string) : string;
(* TargetPath に FileName のファイル名がある場合は TargetPath に無いファイル名（拡張子は同一）を付けて（フルパス名で）返す。 *)


implementation

uses	SysUtils, ShellAPI; (*,
		stru3;                *)


(* ----------------------- Unit Local Procedure / Function ------------------ *)


function  CheckMask(const mask : SFileType; const attr : integer) : boolean;

begin {CheckMask}
	result := false;
	if ((faDirectory or faVolumeID) and attr) = 0 then begin
		result := (attr = 0) and (fdNormalFile in mask);
		if not result and (fdReadOnly in mask)then
			result := (attr and faReadOnly) > 0;
		if not result and (fdHidden in mask) then
			result := (attr and faHidden) > 0;
		if not result and (fdSysFile in mask) then
			result := (attr and faSysFile) > 0;
		if not result and (fdArchive in mask) then
			result := (attr and faArchive) > 0;
	end;
end;  {CheckMask}


procedure FileBackUp(const fn : string);
begin {FileBackUp}
	DeleteFile(ChangeFileExt(fn, '.bak'));
	RenameFile(fn, ChangeFileExt(fn, '.bak'));
end;  {FileBackUp}



(* ----------------------- Interfaced Procedure / Function ------------------ *)



function  FileByte(filename : string) : longint;

var
	f : file of byte;
	fs : integer;

begin {FileByte}
	if FileExists(filename) then begin
		AssignFile(f, filename);
		fs := FileMode;
		FileMode := 0;
		reset(f);
		FileMode := fs;
		result := FileSize(f);
		CloseFile(f);
		end
	else
		result := 0;
end;  {FileByte}


function  IsDirectory(pathname : string) : boolean;

var
	sr : TSearchRec;

begin
	result := false;
	if FindFirst(pathname, faAnyFile, sr) = 0 then
    	result := (sr.Attr and faDirectory) > 0;
end;


procedure FileLists(const path : string; const attr : SFileType; var fl : TStringList);
begin
	EnumFileLists(path, attr, fl, nil);
end;

procedure EnumFileLists(const path : string; const attr : SFileType; var fl : TStringList; const df : EnumProc);

var
	fa : TSearchRec;
	fr : integer;
	dir : string;

begin {FileLists}
	fl.Sorted := true;
	fl.Duplicates := dupIgnore;

	dir := ExtractFilePath(path);
	if FindFirst(path, faAnyFile, fa) = 0 then begin
		repeat
			if CheckMask(attr, fa.Attr) then
				fl.Add(concat(dir, fa.Name));
			if @df <> nil then
				df(fa.Name);
			fr := FindNext(fa);
		until fr <> 0;
	end;
	FindClose(fa);
end;  {FileLists}


procedure RecursiveFileLists(const path : string; const attr : SFileType; var fl : TStringList; const df : EnumProc);

var
	td : TStringList;
	dc : integer;

begin {RecursiveFileLists}
	if @df <> nil then
		df(path);

	td :=  TStringList.Create;
	EnumFileLists(path, attr, fl, nil);

	DirectoryLists(path, td);
	for dc := 0 to td.Count - 1 do
		RecursiveFileLists(concat(td[dc], ExtractFileName(path)), attr, fl, df);
	td.Free;
end;  {RecursiveFileLists}


procedure DirectoryLists(path : string; var fl : TStringList);

var
	fa : TSearchRec;
	fr : integer;

begin {DirectoryLists}
	path := concat(ExtractFilePath(path), '*.*');
	if FindFirst(path, faDirectory, fa) = 0 then
		repeat
			if (fa.Name <> '.') and (fa.Name <> '..') and ((fa.Attr and faDirectory) > 0) then
				fl.Add(concat(ExtractFilePath(path), fa.Name, '\'));
			fr := FindNext(fa);
		until fr <> 0;
	FindClose(fa);
end;  {DirectoryLists}


procedure RecursiveDirectoryLists(const path : string; var fl : TStringList; const df : EnumProc);

var
	sd : TStringList;
	dc : integer;

begin {RecursiveDirectoryLists}
	if @df <> nil then
		df(path);

	fl.Add(path);
	sd := TStringList.Create;
	DirectoryLists(path, sd);
	for dc := 0 to sd.Count - 1 do
		RecursiveDirectoryLists(sd[dc], fl, df);
	sd.Free;
end;  {RecursiveDirectoryLists}


procedure LoadFile(const fn : string; var txt : string);

var
	fp : File;
	fs : integer;
	buf : PChar;

begin {LoadFile}
	AssignFile(fp, fn);
	try
		FileMode := 0;
		reset(fp, 1);
		fs := FileSize(fp);
		buf := StrAlloc(fs + 1);
		BlockRead(fp, buf^, fs);
		SetString(txt, buf, fs);
		StrDispose(buf);
		FileMode := 2;
	finally
		CloseFile(fp);
	end;
end;  {LoadFile}


procedure SaveFile(const fn : string; txt : string);

var
	fp : File;
	fs : integer;
	buf : PChar;

begin {SaveFile}
	fs := length(txt);

	if FileExists(fn) then
		FileBackUp(fn);

	AssignFile(fp, fn);
	try
		rewrite(fp, 1);
		buf := StrAlloc(fs + 1);
		StrPLCopy(buf, txt, fs);
		BlockWrite(fp, buf^, fs);
		StrDispose(buf);
	finally
		CloseFile(fp);
	end;
end;  {SaveFile}


function ParentPath(pn : string) : string;

var
	pp : integer;

begin {ParentPath}
	pp := length(pn) - 1;
	while (pp > 0) and (pn[pp] <> '\') do
		pp := pp - 1;
	result := copy(pn, 1, pp);
end;  {ParentPath}


function  FileToTrashBox(const ah : THandle; const fn : string) : boolean;

var
	FileOp : TSHFileOpStruct;

begin {FileToTrashBox}
	result := true;
	if FileExists(fn) then begin
		with FileOp do begin
			Wnd := ah;
	        wFunc := FO_DELETE;
	        pFrom := PChar(fn);
	        pTo := nil;
	        fFlags := FOF_ALLOWUNDO or FOF_SILENT;
	        fAnyOperationsAborted := false;
	        hNameMappings := nil;
	        lpszProgressTitle := nil;
	    end;
	    result := SHFileOperation(FileOp) = 0;
	end;
end;  {FileToTrashBox}


function  MakeUniqueFileName(const FileName : string; const TargetPath : string) : string;

const
	dess = 'abcdefghijklmnopqrstuvwxyz0123456789';

var
	fn : string;
	ext : string;
	id : integer;

function NoExtFileName(const PathName : string) : string;

var
	fn : string;
	ext : string;

begin {NoExtFileName}
	fn := ExtractFileName(PathName);
	ext := ExtractFileExt(PathName);
	result := copy(fn, 1, length(fn) - length(ext));
end;  {NoExtFileName}

begin {MakeUniqueFileName}
	fn := ExtractFileName(FileName);
	if not FileExists(concat(TargetPath, fn)) then
		result := concat(TargetPath, fn)
	else begin
		fn := NoExtFileName(FileName);
		ext := ExtractFileExt(FileName);
		id := 1;
		while (id <= length(dess)) and FileExists(concat(TargetPath, fn, dess[id], ext)) do
			inc(id);
		if id <= length(dess) then
        	result := concat(TargetPath, fn, dess[id], ext)
		else begin
			repeat
				result := '';
				for id := 1 to 8 do
                	result := concat(result, dess[random(length(dess)) + 1]);
				result := concat(TargetPath, result, ext);
			until not FileExists(result);
		end;
    end;
end;  {MakeUniqueFileName}

initialization
begin
	randomize;
end;

end.