{ -----------------------------------
長いファイル名、短いファイル名相互変換関数
2002/06/05
  作成されていた
2003/03/17
  関数の説明を記述、全体的にコメントなどを修正
  GetShortFullPathName/GetLongFullPathNameは
  不要なのでimplementationだけに実装して
  interfaceにはGetLongFileName/GetShortFileNameを
  準備した。
2005/12/19
  LongShortFileName.pasからFileNameUnit.pasに名前変更
2005/12/29
  CheckUNCPathやCheckDrivePathを正しく実装
2006/12/24(日)
・CheckDrivePathをデバッグ
・PathLevel/CutPathLevelを実装
・testTrailingPathDelimiterを追加
//----------------------------------- }
unit FileNameUnit;

interface

uses
  Windows, SysUtils,
  ShellUnit,
  NetworkUnit,
  StringUnitLight,
  WordDecompose,
  XPtest;

function GetLongFileName(const ShortFileName:string):string;
function GetShortFileName(const LongFileName:string):string;
procedure testGetLongFileName;
procedure testGetShortFileName;

function CheckSameFileName(A, B: String): Boolean;
function CheckUNCPath(Path: String): Boolean;
procedure testCheckUNCPath;
function CheckDrivePath(Path: String): Boolean;
procedure testCheckDrivePath;
procedure testCheckFileFolderPath;

procedure MakeTestFolderFile;
procedure DeleteTestFolderFile;
procedure testFileDirectoryExists;

function ExtractFileNameExcludeExt(const FileName: String): String;

function PathLevel(Path: String): Integer;
procedure testPathLevel;

function CutPathLevel(Path: String; CutCount: Integer): String;
procedure testCutPathLevel;
procedure testTrailingPathDelimiter;

implementation

function CheckPathFollowRule(Path: String): Boolean; forward;


{-------------------------------
//ロングファイル名/ショートファイル名を取得する
    GetLongFileName
    GetShortFileName
備考:       DelphiML検索ワード「ロングファイル」
            2chの情報
            結局、FDelphiのコードよりこちらの方が
            短くてよいだろう
履歴:       2003/03/17
              存在しないファイルを変換した場合
              空文字を返すように修正
//------------------------------}
function GetLongFileName(const ShortFileName:string):string;
var
  Path:string;
  SearchRec:TSearchRec;
begin
  Result := '';
  if ShortFileName = '' then Exit;

  if FileExists(ShortFileName)
    or DirectoryExists(ShortFileName) then
  begin
    Result := ExcludeTrailingPathDelimiter( ShortFileName );
    if ( Length( Result ) = 2 ) and ( Result[2] = ':' ) then Exit;
    if SysUtils.FindFirst( Result, faAnyFile, SearchRec )=0 then
    begin
      Path := GetLongFileName( ExtractFileDir( Result ) );
      Path := IncludeTrailingPathDelimiter( Path );
      Result := Path + SearchRec.Name;
    end;
    SysUtils.FindClose( SearchRec );
  end;
end;

function GetShortFileName(const LongFileName:string):string;
var
  Path:string;
  SearchRec:TSearchRec;
begin
  Result := '';
  if LongFileName = '' then Exit;

  if FileExists(LongFileName)
    or DirectoryExists(LongFileName) then
  begin
    Result := ExcludeTrailingPathDelimiter( LongFileName );
    if ( Length( Result ) = 2 ) and ( Result[2] = ':' ) then Exit;
    if SysUtils.FindFirst( Result, faAnyFile, SearchRec )=0 then
    begin
      Path := GetShortFileName( ExtractFileDir( Result ) );
      Path := IncludeTrailingPathDelimiter( Path );
      if SearchRec.FindData.cAlternateFileName <> '' then
        Result := Path + SearchRec.FindData.cAlternateFileName
      else
        Result := Path + SearchRec.Name;
    end;
    SysUtils.FindClose( SearchRec );
  end;
end;

//テスト用テキストファイルを作成する関数
procedure MakeTestFolderFile;
var
  F: File;
  Str: String;
  FileName: String;
begin
  Str := 'テスト';
  FileName := 'C:\Temp\AA  AA\BB B\CC   CCC\itteyoshi.txt';

  {↓テスト用テキストファイルを作成}
  ForceDirectories(ExtractFileDir(FileName));
  AssignFile(F, FileName);
  Rewrite(F, Length(Str));
  try
    if Length(Str) > 0 then
      BlockWrite(F, PChar(Str)^, 1);
  finally
    CloseFile(F);
  end;
end;

//テスト用テキストファイルを削除する関数
procedure DeleteTestFolderFile;
var
  FileName: String;
begin
  FileName := 'C:\Temp\AA  AA\BB B\CC   CCC\itteyoshi.txt';

  ForceDeleteFile(0, FileName);
  ForceDeleteFolder(0, ExtractFileDir(FileName));
  ForceDeleteFolder(0, ExtractFileDir(ExtractFileDir(FileName)));
  ForceDeleteFolder(0, ExtractFileDir(ExtractFileDir(ExtractFileDir(FileName))));
end;

procedure testGetLongFileName;
begin
  MakeTestFolderFile;
  //通常の変換
  Check('C:\Temp\AA  AA\BB B\CC   CCC\itteyoshi.txt',
    GetLongFileName('C:\TEMP\AAAA~1\BBB~1\CCCCC~1\ITTEYO~1.TXT') );
  Check('C:\Temp\AA  AA\BB B\CC   CCC',
    GetLongFileName('C:\TEMP\AAAA~1\BBB~1\CCCCC~1') );

  //変換しない
  Check('C:\Temp\AA  AA\BB B\CC   CCC\itteyoshi.txt',
    GetLongFileName('C:\Temp\AA  AA\BB B\CC   CCC\itteyoshi.txt') );
  Check('C:\Temp\AA  AA\BB B\CC   CCC',
    GetLongFileName('C:\Temp\AA  AA\BB B\CC   CCC') );
  DeleteTestFolderFile;

  //存在しないファイルとフォルダ
  Check('', GetLongFileName('C:\TempTempTemp'));
  Check('', GetLongFileName('C:\Temp\a.txt'));
end;

procedure testGetShortFileName;
begin
  MakeTestFolderFile;
  //通常の変換
  Check('C:\Temp\AAAA~1\BBB~1\CCCCC~1\ITTEYO~1.TXT',
    GetShortFileName('C:\Temp\AA  AA\BB B\CC   CCC\itteyoshi.txt') );
  Check('C:\Temp\AAAA~1\BBB~1\CCCCC~1',
    GetShortFileName('C:\Temp\AA  AA\BB B\CC   CCC') );

  //変換しない
  Check('C:\Temp\AAAA~1\BBB~1\CCCCC~1\ITTEYO~1.TXT',
    GetShortFileName('C:\Temp\AAAA~1\BBB~1\CCCCC~1\ITTEYO~1.TXT') );
  Check('C:\Temp\AAAA~1\BBB~1\CCCCC~1',
    GetShortFileName('C:\Temp\AAAA~1\BBB~1\CCCCC~1') );
  DeleteTestFolderFile;

  //存在しないファイルとフォルダ
  Check('', GetShortFileName('C:\TempTempTemp'));
  Check('', GetShortFileName('C:\Temp\a.txt'));
end;
//------------------------------


{-------------------------------
//ファイル名を比較して
機能:       文字列が同一のファイルを示しているのかどうかを判断します。
            存在するファイルしか同一かどうか判断できません。
            A,Bは短いファイル名でも長いファイル名でもOKです。
戻り値:     true:同じファイル false:異なるファイル
備考:       ユニットSysUtilsのSameFileName関数で代用できるかもしれません
履歴:       2002/02/11
//------------------------------}
function CheckSameFileName(A, B: String): Boolean;
var
  OldMode: UINT;// エラーモード保持用
begin
  OldMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  if FileExists(A) and FileExists(B) then
  begin
    A := GetLongFileName(A);
    B := GetLongFileName(B);

    if SameText(A, B) then
    begin
      Result := True;
    end else
    begin
      Result := False;
    end;

  end else
  begin
    Result := False;
  end;
  SetErrorMode(OldMode);
end;
//------------------------------

{-------------------------------
//  DirectoryExists/FileExistsや
    ExtractFileDriveの動作を調査する
備考:
履歴:       2005/12/29
//------------------------------}
//の動作をテストする関数
procedure testFileDirectoryExists;
begin
  Check(True, DirectoryExists('C:\Temp'));
  Check(True, DirectoryExists('C:\Temp\'));
  Check(True, DirectoryExists('C:\'));
  Check(True, DirectoryExists('C:'));
  {↓マシン名はDirではない}
  Check(False, DirectoryExists('\\'+GetMachineNetworkInfo.HostName));
  Check(True, DirectoryExists('\\'+GetMachineNetworkInfo.HostName+'\TEMP'));
  {↑共有フォルダはDir}

  MakeTestFolderFile;
  Check(True, FileExists('C:\Temp\AA  AA\BB B\CC   CCC\itteyoshi.txt'));
  Check(True, FileExists('C:\Temp\AA  AA\BB B\CC   CCC\itteyoshi.txt'));
  DeleteTestFolderFile;
end;

procedure testExtractFileDrive;
begin
  Check('c:', ExtractFileDrive('c:\aaa\bbb.txt'));
  Check('C:', ExtractFileDrive('C:\aaa\bbb.txt'));
end;
//------------------------------

{-------------------------------
//  UNC(=Universal Naming Convention)パスかどうかを判断する関数
機能:       文字列が3文字以上であって
            先頭が『\\?』って形になっていて
            途中でファイル禁止文字や『\\』がない
            かどうかを判断する関数
備考:
履歴:       2005/12/28
//------------------------------}
function CheckUNCPath(Path: String): Boolean;
begin
  Result := False;
  if 3 <= Length(Path) then
  begin
    if (Path[1]=PathDelim)
      and (Path[2]=PathDelim)
      and (not (Path[3]=PathDelim)) then
    begin
      Result := True;
    end;
  end;

  if (Result = True) and (CheckPathFollowRule(Path)=False)  then
  begin
    Result := False;
  end;
end;

procedure testCheckUNCPath;
begin
  Check(False, CheckUNCPath('c:\aaa\bbb.txt'));
  Check(False, CheckUNCPath('c:\'));
  Check(False, CheckUNCPath('c:'));
  Check(True, CheckUNCPath('\\EXELION'));
  Check(True, CheckUNCPath('\\Exelion\TEMP'));
  Check(False, CheckUNCPath('\\'));
end;
//------------------------------

{-------------------------------
//  通常のドライブパスかどうかを判断する関数
機能:       文字列が2文字以上であって
            先頭が『X:』って形になっていて
            途中でファイル禁止文字や『\\』がない
            かどうかを判断する関数
備考:
履歴:       2005/12/28
            2006/12/24(日) 誤動作を若干修正
//------------------------------}
function CheckDrivePath(Path: String): Boolean;
begin
  Result := False;
  if Length(Path)<=1 then
  begin
    Result := False;
    Exit;
  end;
  {↑一文字の場合はどうやってもパスにならない}

  if 2 <= Length(Path) then
  begin
    if (Path[2]=DriveDelim)
      and CheckWideCharInTable(WideChar(Path[1]), hanAlphaTbl) then
    begin
      Result := True;
    end else
    begin
      Result := False;
      Exit;
    end;
  end;

  if 3 <= Length(Path) then
  begin
    if Path[3]=PathDelim then
    begin
      Result := True;
    end else
    begin
      Result := False;
      Exit;
    end;
  end;

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

procedure testCheckDrivePath;
begin
  Check(True, CheckDrivePath('c:\aaa\bbb.txt'));
  Check(True, CheckDrivePath('c:\'));
  Check(True, CheckDrivePath('c:'));
  Check(True, CheckDrivePath('D:\aaa\bbb.txt'));
  Check(True, CheckDrivePath('D:\'));
  Check(True, CheckDrivePath('D:'));
  {↓二文字のドライブパスは受け付けない}
  Check(False, CheckDrivePath('aa:'));
  Check(False, CheckDrivePath('AA:'));
  Check(False, CheckDrivePath('aa:\'));
  Check(False, CheckDrivePath('AA:\'));
  Check(False, CheckDrivePath('AA:\temp'));
  Check(False, CheckDrivePath('abc:\abc'));
  Check(False, CheckDrivePath('\\EXELION'));
  Check(False, CheckDrivePath('\\Exelion\TEMP'));
  Check(False, CheckDrivePath('\\'));
  Check(False, CheckDrivePath('\:'));
  Check(False, CheckDrivePath('\:\'));
end;
//------------------------------

{-------------------------------
//  CheckDrivePathとCheckUNCPathで使われる内部関数
機能:       文字列が1文字しかなかったり
            UNC指定以外の場所(つまり1文字目以外)で"\\"が使われていたり
            その他禁止文字が使われていたりして
            Pathがファイルパスとして成り立つかどうかを判断する関数
備考:
履歴:       2005/12/29
//------------------------------}
function CheckPathFollowRule(Path: String): Boolean;
var
  PathBackside: String;
begin
  Result := True;
  if Length(Path) <= 1 then
  begin
    Result := False;
    Exit;
  end;

  if 3 <= Length(Path) then
  begin
    PathBackside := Copy(Path, 3, Length(Path));
    if InStr('\\', PathBackside, 3, MaxInt) then
    begin
      Result := False;
      Exit;
    end;

    if CheckStrInTable(PathBackside, '/:,;*?"<>|') <> itAllExclude then
    begin
      Result := False;
      Exit;
    end;
  end;
end;

procedure testCheckFileFolderPath;
begin
  Check(True, CheckPathFollowRule('c:\aaa\bbb.txt'));
  Check(True, CheckPathFollowRule('c:\'));
  Check(True, CheckPathFollowRule('c:'));
  Check(True, CheckPathFollowRule('\\EXELION'));
  Check(True, CheckPathFollowRule('\\Exelion\TEMP'));
  Check(True, CheckPathFollowRule('\\'));
  Check(False, CheckPathFollowRule('c:\aaa\\bbb.txt'));
  Check(False, CheckPathFollowRule('\\Exelion\\TEMP'));
end;
//------------------------------

{-------------------------------
//  ExtractFileNameExcludeExt
機能:       拡張子もディレクトリパスもない
            ファイル名を取得する
備考:       ファイル名が正しくない場合
            戻り値はChangeFileExtやExtractFileNameの処理に依存する
履歴:       2006/02/18
//------------------------------}
function ExtractFileNameExcludeExt(const FileName: String): String;
begin
  Result := ChangeFileExt(ExtractFileName(FileName), '');
end;
//------------------------------

{-------------------------------
//  ファイルパスの階層を調べる関数
機能:
備考:
履歴:       2006/12/24(日) 00:33
//------------------------------}
function PathLevel(Path: String): Integer;
begin
  Result := -1;
  if CheckDrivePath(Path) then
  begin
    Result := WordCount(PathDelim, Path, dmUserFriendly)-1;
  end else
  if CheckUNCPath(Path) then
  begin
    Result := WordCount(PathDelim, Path, dmUserFriendly)-1;
  end else
  begin
    Exit;
  end;
end;

procedure testPathLevel;
begin
  Check(-1, PathLevel('abc'));
  Check(-1, PathLevel('123'));
  Check(-1, PathLevel('123:'));
  Check(-1, PathLevel('123:\'));
  Check(-1, PathLevel('\'));
  Check(-1, PathLevel('\\'));
  Check(-1, PathLevel('\:\'));
  Check(0, PathLevel('C:'));
  Check(0, PathLevel('C:\'));
  Check(0, PathLevel('D:'));
  Check(0, PathLevel('D:\'));
  Check(-1,PathLevel('AB:'));
  Check(-1,PathLevel('AB:\'));
  Check(1, PathLevel('C:\A'));
  Check(1, PathLevel('C:\Temp'));
  Check(1, PathLevel('C:\Temp\'));
  Check(2, PathLevel('C:\A\test.txt'));
  Check(2, PathLevel('C:\A\test'));
  Check(2, PathLevel('C:\A\test\'));
  Check(4, PathLevel('C:\Temp\TempA\TempB\aaa.txt'));
  Check(4, PathLevel('C:\Temp\TempA\TempB\aaa'));
  Check(4, PathLevel('C:\Temp\TempA\TempB\aaa\'));
  Check(-1, PathLevel('\test'));
  Check(-1, PathLevel('\t:'));
  Check(-1, PathLevel('\t:\'));
  Check(-1, PathLevel('\t\'));
  Check(0, PathLevel('\\test'));
  Check(0, PathLevel('\\test\'));
  Check(1, PathLevel('\\test\temp'));
  Check(1, PathLevel('\\test\temp\'));
  Check(2, PathLevel('\\test\temp\test.txt'));
  Check(4, PathLevel('\\A\Temp\TempA\TempB\aaa.txt'));
  Check(4, PathLevel('\\A\Temp\TempA\TempB\aaa'));
  Check(4, PathLevel('\\A\Temp\TempA\TempB\aaa\'));
end;
//------------------------------

{-------------------------------
//  ファイルパスの階層を切り取る関数
機能:       指定した階層(CutCount)分にフォルダを上に上がる関数
備考:
履歴:       2006/12/24(日) 00:33
//------------------------------}
function CutPathLevel(Path: String; CutCount: Integer): String;
var
  Level: Integer;
  i: Integer;
begin
  Result := '';
  if CutCount < 0 then Exit;
  if CutCount = 0 then
  begin
    Result := Path;
    Exit;
  end;

  Level := PathLevel(Path);
  if Level = -1 then Exit;

  if Level < CutCount then
  begin
    Exit;
  end else
  begin
    for i := 0 to Level - CutCount do
    begin
      Result := Result +
        WordGet(PathDelim, Path, i, dmUserFriendly) + PathDelim;
    end;
    if CheckUNCPath(Path) then
    begin
      Result := StringOfChar(PathDelim, 2) + Result;
    end;
  end;

end;

procedure testCutPathLevel;
begin
  Check('C:\Temp\TempA\TempB\aaa.txt', CutPathLevel('C:\Temp\TempA\TempB\aaa.txt', 0));
  Check('C:\Temp\TempA\TempB\', CutPathLevel('C:\Temp\TempA\TempB\aaa.txt', 1));
  Check('C:\Temp\TempA\', CutPathLevel('C:\Temp\TempA\TempB\aaa.txt', 2));
  Check('C:\', CutPathLevel('C:\Temp\TempA\TempB\aaa.txt', 4));
  Check('', CutPathLevel('C:\Temp\TempA\TempB\aaa.txt', 5));

  Check('C:\Temp\TempA\TempB\aaa', CutPathLevel('C:\Temp\TempA\TempB\aaa', 0));
  Check('C:\Temp\TempA\TempB\aaa\', CutPathLevel('C:\Temp\TempA\TempB\aaa\', 0));
  Check('C:\Temp\TempA\TempB\', CutPathLevel('C:\Temp\TempA\TempB\aaa', 1));
  Check('C:\Temp\TempA\TempB\', CutPathLevel('C:\Temp\TempA\TempB\aaa\', 1));

  Check('\\Test\Temp\TempA\TempB\aaa.txt', CutPathLevel('\\Test\Temp\TempA\TempB\aaa.txt', 0));
  Check('\\Test\Temp\TempA\TempB\', CutPathLevel('\\Test\Temp\TempA\TempB\aaa.txt', 1));
  Check('\\Test\Temp\TempA\', CutPathLevel('\\Test\Temp\TempA\TempB\aaa.txt', 2));
  Check('\\Test\', CutPathLevel('\\Test\Temp\TempA\TempB\aaa.txt', 4));
  Check('', CutPathLevel('\\Test\Temp\TempA\TempB\aaa.txt', 5));

  Check('\\Test\Temp\TempA\TempB\aaa', CutPathLevel('\\Test\Temp\TempA\TempB\aaa', 0));
  Check('\\Test\Temp\TempA\TempB\aaa\', CutPathLevel('\\Test\Temp\TempA\TempB\aaa\', 0));
  Check('\\Test\Temp\TempA\TempB\', CutPathLevel('\\Test\Temp\TempA\TempB\aaa', 1));
  Check('\\Test\Temp\TempA\TempB\', CutPathLevel('\\Test\Temp\TempA\TempB\aaa\', 1));
end;
//------------------------------

{-------------------------------
//  Include/ExcludeTrailingPathDelimiterの動作を調べるテスト
機能:
備考:
履歴:       2006/12/24(日) 00:33
//------------------------------}
procedure testTrailingPathDelimiter;
begin
  Check('C:\Temp\', IncludeTrailingPathDelimiter('C:\Temp\'));
  Check('C:\Temp',  ExcludeTrailingPathDelimiter('C:\Temp'));
  Check('C:\',  IncludeTrailingPathDelimiter('C:'));
  Check('C:',   ExcludeTrailingPathDelimiter('C:\'));
end;
//------------------------------

end.