Advertisement
Guest User

Delphi relative file manipulation functions

a guest
Jan 15th, 2015
469
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Delphi 15.74 KB | None | 0 0
  1. unit ShellFileSupport;
  2.  
  3. interface
  4.  
  5. type
  6.   TDriveNumber    = 0..25;
  7.   TPathCharType   = (gctInvalid, gctLFNChar, gctSeparator, gctShortChar, gctWild);
  8.   TPathCharTypes  = set of TPathCharType;
  9.   TCleanupResult  = (pcsReplacedChar, pcsRemovedChar, pcsTruncated);
  10.   TCleanupResults = set of TCleanupResult;
  11.   PCleanupResults = ^TCleanupResults;
  12.  
  13. const
  14.   InvalidDrive = TDriveNumber(-1);
  15.  
  16. // Возвращает тип символа из пути
  17. function PathGetCharType(const AChar: Char): TPathCharTypes;
  18.  
  19. // Возвращает номер диска из пути (InvalidDrive при ошибке)
  20. function PathGetDriveNumber(const APath: String): TDriveNumber;
  21.  
  22. // Формирует путь к корневому каталогу заданного диска
  23. function PathBuildRoot(const ADrive: TDriveNumber): String;
  24.  
  25. // Канонизирует путь, удаляя из него специальные каталоги '.' и '..'
  26. function PathCanonicalize(const APath: String): String;
  27.  
  28. // Соединяет два пути, добавляя, при необходимости, разделитель пути
  29. function PathAppend(const APath, AMore: String): String;
  30.  
  31. // Аналог PathAppend, но возвращает каноничный путь (с удалёнными '.' и '..')
  32. function PathCombine(const APath, AMore: String): String;
  33.  
  34. // Возвращает True, если указанный путь (файл/каталог) существует
  35. // Реализуем на случай, если вы не хотите использовать бажный FileExists/DirectoryExists из Delphi
  36. // См.
  37. // http://qc.embarcadero.com/wc/qcmain.aspx?d=3513
  38. // http://qc.embarcadero.com/wc/qcmain.aspx?d=10731
  39. // http://qc.embarcadero.com/wc/qcmain.aspx?d=52905
  40. function PathFileExists(const APath: String): Boolean;
  41.  
  42. // Возвращает True, если путь - каталог
  43. // Реализуем на случай, если вы не хотите использовать бажный FileExists/DirectoryExists из Delphi
  44. // См.
  45. // http://qc.embarcadero.com/wc/qcmain.aspx?d=3513
  46. // http://qc.embarcadero.com/wc/qcmain.aspx?d=10731
  47. // http://qc.embarcadero.com/wc/qcmain.aspx?d=52905
  48. function PathIsDirectory(const APath: String): Boolean;
  49.  
  50. // Возвращает True, если путь не содержит разделителей пути (':' и '\')
  51. function PathIsFileSpec(const APath: String): Boolean;
  52.  
  53. // Возвращает True, если путь - относительный
  54. function PathIsRelative(const APath: String): Boolean;
  55.  
  56. // Возвращает True, если путь - абсолютный
  57. function PathIsAbsolute(const APath: String): Boolean;
  58.  
  59. // Заключает строку в кавычки при необходимости (наличие пробелов)
  60. function PathQuoteSpaces(const APath: String; const AForce: Boolean = False): String;
  61.  
  62. // Формирует относительный путь к ATo из (относительно) AFrom (ведомый '\' обозначает каталог)
  63. function PathRelativePathTo(const AFrom, ATo: String): String;
  64.  
  65. // Разрешает относительное имя в абсолютное, дополнительно канонизируя путь
  66. function PathSearchAndQualify(const APath: String): String;
  67.  
  68. // Возвращает короткое имя по длинному
  69. function PathGetShortPath(const APath: String): String;
  70.  
  71. // Возвращает длинное имя по короткому
  72. function PathGetLFNPath(const APath: String): String;
  73.  
  74. // Возвращает True, если путь - допустим
  75. function PathIsValid(const APath: String): Boolean;
  76.  
  77. // Создаёт командную строку для запуска программы. Результат этой функции можно передавать в CreateProcess
  78. function PathProcessCommand(const AProgram: String; const AParameters: array of String): String;
  79.  
  80. implementation
  81.  
  82. {$A+}
  83. {$R+}
  84. {$Z4}
  85. {$WARN SYMBOL_PLATFORM OFF}
  86.  
  87. uses
  88.   Windows, SysUtils;
  89.  
  90. function Kernel32: HMODULE; forward;
  91. function ShlwAPI: HMODULE; forward;
  92.  
  93. {$IFNDEF UNICODE}
  94. type
  95.   UnicodeString = WideString;
  96. {$ENDIF}
  97.  
  98. procedure CreateBuffer(out Buffer: String; const ALen: Integer); overload;
  99. begin
  100.   SetLength(Buffer, ALen);
  101.   FillChar(Pointer(Buffer)^, ALen * SizeOf(Char), 0);
  102. end;
  103.  
  104. procedure CreateBuffer(out Buffer: String; const APath: String); overload;
  105. begin
  106.   CreateBuffer(Buffer, MAX_PATH);
  107.   Move(Pointer(APath)^, Pointer(Buffer)^, Length(APath) * SizeOf(Char));
  108. end;
  109.  
  110. {$IFNDEF UNICODE}
  111. procedure CreateBuffer(out Buffer: UnicodeString; const ALen: Integer); overload;
  112. begin
  113.   SetLength(Buffer, ALen);
  114.   FillChar(Pointer(Buffer)^, ALen * SizeOf(WideChar), 0);
  115. end;
  116.  
  117. procedure CreateBuffer(out Buffer: UnicodeString; const APath: String); overload;
  118. var
  119.   Path: UnicodeString;
  120. begin
  121.   CreateBuffer(Buffer, MAX_PATH);
  122.   Path := APath;
  123.   Move(Pointer(Path)^, Pointer(Buffer)^, Length(APath) * SizeOf(WideChar));
  124. end;
  125. {$ENDIF}
  126.  
  127. function PathQuoteSpaces(const APath: String; const AForce: Boolean): String;
  128. begin
  129.   if (not AForce) and
  130.      (Pos(' ', APath) <= 0) and
  131.      (Pos('"', APath) <= 0) then
  132.   begin
  133.     Result := APath;
  134.     Exit;
  135.   end;
  136.  
  137.   Result := '"' + StringReplace(APath, '"', '\"', [rfReplaceAll]) + '"';
  138.   if (Length(Result) > 2) and
  139.      (Result[Length(Result) - 1] = '"') then
  140.     Insert('\', Result, Length(Result) - 1);
  141. end;
  142.  
  143. var
  144.   FPathRelativePathTo: function(APath, AFrom: PChar; AttrFrom: DWORD; ATo: PChar; AttrTo: DWORD): BOOL; stdcall;
  145.  
  146. function PathRelativePathTo(const AFrom, ATo: String): String;
  147. var
  148.   Buffer, From, ToD: String;
  149.   AttrFrom, AttrTo: DWORD;
  150.  
  151. begin
  152.   if not Assigned(FPathRelativePathTo) then
  153.   begin
  154.     FPathRelativePathTo := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathRelativePathToW'{$ELSE}'PathRelativePathToA'{$ENDIF});
  155.     Win32Check(Assigned(FPathRelativePathTo));
  156.   end;
  157.  
  158.   Assert(AFrom <> '');
  159.   Assert(ATo <> '');
  160.  
  161.   if AFrom[Length(AFrom)] = PathDelim then
  162.     AttrFrom := FILE_ATTRIBUTE_DIRECTORY
  163.   else
  164.     AttrFrom := 0;
  165.   if ATo[Length(ATo)] = PathDelim then
  166.     AttrTo := FILE_ATTRIBUTE_DIRECTORY
  167.   else
  168.     AttrTo := 0;
  169.  
  170.   From := ExcludeTrailingPathDelimiter(PathCanonicalize(AFrom));
  171.   ToD  := ExcludeTrailingPathDelimiter(PathCanonicalize(ATo));
  172.  
  173.   CreateBuffer(Buffer, MAX_PATH);
  174.   if FPathRelativePathTo(PChar(Buffer), PChar(From), AttrFrom, PChar(ToD), AttrTo) then
  175.     Result := PChar(Buffer)
  176.   else
  177.     Result := '';
  178. end;
  179.  
  180. var
  181.   FGetShortPathName: function(ALong, AShort: PChar; Len: Integer): Integer; stdcall;
  182.  
  183. function PathGetShortPath(const APath: String): String;
  184. begin
  185.   if not Assigned(FGetShortPathName) then
  186.   begin
  187.     FGetShortPathName := GetProcAddress(Kernel32, {$IFDEF UNICODE}'GetShortPathNameW'{$ELSE}'GetShortPathNameA'{$ENDIF});
  188.     Win32Check(Assigned(FGetShortPathName));
  189.   end;
  190.  
  191.   CreateBuffer(Result, 32768);
  192.   SetLength(Result, FGetShortPathName(PChar(APath), PChar(Result), 32768));
  193.   if Result = '' then
  194.     Result := APath;
  195. end;
  196.  
  197. var
  198.   FGetLongPathName: function(AShort, ALong: PChar; Len: Integer): Integer; stdcall;
  199.  
  200. function PathGetLFNPath(const APath: String): String;
  201. begin
  202.   if not Assigned(FGetLongPathName) then
  203.   begin
  204.     FGetLongPathName := GetProcAddress(Kernel32, {$IFDEF UNICODE}'GetLongPathNameW'{$ELSE}'GetLongPathNameA'{$ENDIF});
  205.     Win32Check(Assigned(FGetLongPathName));
  206.   end;
  207.  
  208.   CreateBuffer(Result, 32768);
  209.   SetLength(Result, FGetLongPathName(PChar(APath), PChar(Result), 32768));
  210.   if Result = '' then
  211.     Result := APath;
  212. end;
  213.  
  214. function PathProcessCommand(const AProgram: String; const AParameters: array of String): String;
  215. var
  216.   X: Integer;
  217.   Param: String;
  218. begin
  219.   Result := PathQuoteSpaces(AProgram);
  220.  
  221.   for X := 0 to High(AParameters) do
  222.   begin
  223.     if PathFileExists(AParameters[X]) then
  224.       Param := PathQuoteSpaces({$IFDEF UNICODE}PathGetShortPath({$ENDIF}AParameters[X]{$IFDEF UNICODE}){$ENDIF})
  225.     else
  226.       Param := PathQuoteSpaces(AParameters[X]);
  227.     Result := Result + ' ' + Param;
  228.   end;
  229. end;
  230.  
  231. function PathIsValid(const APath: String): Boolean;
  232. const
  233.   UNCWPrefix = '\\?';
  234. var
  235.   Path: String;
  236.   I: Integer;
  237. begin
  238.   if APath = '' then
  239.   begin
  240.     Result := False;
  241.     Exit;
  242.   end;
  243.  
  244.   // Код DRON с DK: функция разбивает путь на части и проверяет каждую часть вызовом MoveFile
  245.   // MoveFile вернёт либо OK, либо ERROR_ALREADY_EXISTS для корректных частей;
  246.   // и вернёт прочие ошибки для зарезервированных символов, зарезервированных имён (COM, etc.), неподдерживаемых нижележащей файловой системе символах
  247.   Result := False;
  248.   Path := APath;
  249.   repeat
  250.     I := LastDelimiter('\/', Path);
  251.     if (Path <> '') and
  252.        (
  253.          (Path[Length(Path)] = '.') or
  254.          (Path[Length(Path)] = ' ')
  255.        ) then
  256.       Exit;
  257.     MoveFile(nil, PChar(Path));
  258.     if (GetLastError = ERROR_ALREADY_EXISTS) or
  259.        (
  260.          (GetFileAttributes(PChar(Copy(Path, I + 1, MaxInt))) = INVALID_FILE_ATTRIBUTES) and
  261.          (GetLastError = ERROR_INVALID_NAME)
  262.        ) then
  263.       Exit;
  264.     if I > 0 then
  265.       Path := Copy(Path, 1, I - 1);
  266.     if (I = 4) and (Path = UNCWPrefix) then
  267.       I := 0;
  268.   until I = 0;
  269.   Result := True;
  270. end;
  271.  
  272. function PathAppend(const APath, AMore: String): String;
  273. var
  274.   Path, More: String;
  275. begin
  276.   if AMore = '' then
  277.   begin
  278.     Result := APath;
  279.     Exit;
  280.   end;
  281.  
  282.   Path := StringReplace(APath, '/', PathDelim, [rfReplaceAll]);
  283.   More := StringReplace(AMore, '/', PathDelim, [rfReplaceAll]);
  284.   if More[1] = PathDelim then
  285.     Result := ExcludeTrailingPathDelimiter(Path) + More
  286.   else
  287.     Result := IncludeTrailingPathDelimiter(Path) + More;
  288. end;
  289.  
  290. function PathCombine(const APath, AMore: String): String;
  291. begin
  292.   Result := PathCanonicalize(PathAppend(APath, AMore));
  293. end;
  294.  
  295. var
  296.   FPathGetCharType: function(Ch: Char): UINT; stdcall;
  297.  
  298. function PathGetCharType(const AChar: Char): TPathCharTypes;
  299. const
  300.   GCT_INVALID   = 0;
  301.   GCT_LFNCHAR   = 1;
  302.   GCT_SHORTCHAR = 2;
  303.   GCT_WILD      = 4;
  304.   GCT_SEPARATOR = 8;
  305. var
  306.   R: UINT;
  307. begin
  308.   Result := [];
  309.  
  310.   if not Assigned(FPathGetCharType) then
  311.   begin
  312.     FPathGetCharType := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathGetCharTypeW'{$ELSE}'PathGetCharTypeA'{$ENDIF});
  313.     Win32Check(Assigned(FPathGetCharType));
  314.   end;
  315.  
  316.   R := FPathGetCharType(AChar);
  317.   if R = GCT_INVALID then
  318.   begin
  319.     Result := [gctInvalid];
  320.     Exit;
  321.   end;
  322.  
  323.   if (R and GCT_LFNCHAR) <> 0 then
  324.     Include(Result, gctLFNChar);
  325.   if (R and GCT_SEPARATOR) <> 0 then
  326.     Include(Result, gctSeparator);
  327.   if (R and GCT_SHORTCHAR) <> 0 then
  328.     Include(Result, gctShortChar);
  329.   if (R and GCT_WILD) <> 0 then
  330.     Include(Result, gctWild);
  331. end;
  332.  
  333. var
  334.   FPathGetDriveNumber: function(Path: PChar): Integer; stdcall;
  335.  
  336. function PathGetDriveNumber(const APath: String): TDriveNumber;
  337. var
  338.   R: Integer;
  339. begin
  340.   if not Assigned(FPathGetDriveNumber) then
  341.   begin
  342.     FPathGetDriveNumber := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathGetDriveNumberW'{$ELSE}'PathGetDriveNumberA'{$ENDIF});
  343.     Win32Check(Assigned(FPathGetDriveNumber));
  344.   end;
  345.  
  346.   R := FPathGetDriveNumber(PChar(APath));
  347.   if R < 0 then
  348.     Result := InvalidDrive
  349.   else
  350.     Result := TDriveNumber(R);
  351. end;
  352.  
  353. var
  354.   FPathBuildRoot: function(Root: PChar; I: Integer): PChar; stdcall;
  355.  
  356. function PathBuildRoot(const ADrive: TDriveNumber): String;
  357. var
  358.   Buffer: String;
  359. begin
  360.   if not Assigned(FPathBuildRoot) then
  361.   begin
  362.     FPathBuildRoot := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathBuildRootW'{$ELSE}'PathBuildRootA'{$ENDIF});
  363.     Win32Check(Assigned(FPathBuildRoot));
  364.   end;
  365.  
  366.   CreateBuffer(Buffer, 4);
  367.   Result := FPathBuildRoot(PChar(Buffer), Ord(ADrive));
  368. end;
  369.  
  370. var
  371.   FPathCanonicalize: function(ADst, ASrc: PChar): BOOL; stdcall;
  372.  
  373. function PathCanonicalize(const APath: String): String;
  374. var
  375.   Buffer, Path: String;
  376.   X: Integer;
  377. begin
  378.   if not Assigned(FPathCanonicalize) then
  379.   begin
  380.     FPathCanonicalize := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathCanonicalizeW'{$ELSE}'PathCanonicalizeA'{$ENDIF});
  381.     Win32Check(Assigned(FPathCanonicalize));
  382.   end;
  383.  
  384.   CreateBuffer(Buffer, MAX_PATH);
  385.   Path := StringReplace(APath, '/', PathDelim, [rfReplaceAll]);
  386.   Win32Check(FPathCanonicalize(PChar(Buffer), PChar(Path)));
  387.   Result := PChar(Buffer);
  388.  
  389.   // Remove double '\'
  390.   for X := Length(Result) downto 3 do
  391.     if (Result[X] = PathDelim) and
  392.        (Result[X - 1] = PathDelim) then
  393.       Delete(Result, X, 1);
  394. end;
  395.  
  396. var
  397.   FPathSearchAndQualify: function(APath, AFullyQualifiedPath: PChar; Len: UINT): BOOL; stdcall;
  398.  
  399. function PathSearchAndQualify(const APath: String): String;
  400. var
  401.   Buffer: String;
  402. begin
  403.   if not Assigned(FPathSearchAndQualify) then
  404.   begin
  405.     FPathSearchAndQualify := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathSearchAndQualifyW'{$ELSE}'PathSearchAndQualifyA'{$ENDIF});
  406.     Win32Check(Assigned(FPathSearchAndQualify));
  407.   end;
  408.  
  409.   CreateBuffer(Buffer, MAX_PATH);
  410.   Win32Check(FPathSearchAndQualify(PChar(APath), PChar(Buffer), MAX_PATH));
  411.   Result := PChar(Buffer);
  412. end;
  413.  
  414. var
  415.   FPathFileExists: function(Path: PChar): BOOL; stdcall;
  416.  
  417. function PathFileExists(const APath: String): Boolean;
  418. begin
  419.   if not Assigned(FPathFileExists) then
  420.   begin
  421.     FPathFileExists := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathFileExistsW'{$ELSE}'PathFileExistsA'{$ENDIF});
  422.     Win32Check(Assigned(FPathFileExists));
  423.   end;
  424.  
  425.   Result := FPathFileExists(PChar(APath));
  426. end;
  427.  
  428. var
  429.   FPathIsDirectory: function(Path: PChar): UINT; stdcall;
  430.  
  431. function PathIsDirectory(const APath: String): Boolean;
  432. begin
  433.   if not Assigned(FPathIsDirectory) then
  434.   begin
  435.     FPathIsDirectory := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathIsDirectoryW'{$ELSE}'PathIsDirectoryA'{$ENDIF});
  436.     Win32Check(Assigned(FPathIsDirectory));
  437.   end;
  438.  
  439.   Result := FPathIsDirectory(PChar(APath)) <> 0;
  440. end;
  441.  
  442. var
  443.   FPathIsFileSpec: function(Path: PChar): BOOL; stdcall;
  444.  
  445. function PathIsFileSpec(const APath: String): Boolean;
  446. begin
  447.   if not Assigned(FPathIsFileSpec) then
  448.   begin
  449.     FPathIsFileSpec := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathIsFileSpecW'{$ELSE}'PathIsFileSpecA'{$ENDIF});
  450.     Win32Check(Assigned(FPathIsFileSpec));
  451.   end;
  452.  
  453.   Result := FPathIsFileSpec(PChar(APath));
  454. end;
  455.  
  456. var
  457.   FPathIsRelative: function(Path: PChar): BOOL; stdcall;
  458.  
  459. function PathIsRelative(const APath: String): Boolean;
  460. var
  461.   X: Integer;
  462. begin
  463.   // http://stackoverflow.com/questions/26099361/is-it-a-winapi-bug-with-pathisrelative-function
  464.   X := Pos(':', APath);
  465.   if (X > 0) and
  466.      (X < Length(APath)) and
  467.      (APath[X + 1] <> PathDelim) and
  468.      (APath[X + 1] <> '/') then
  469.   begin
  470.     Result := True;
  471.     Exit;
  472.   end;
  473.  
  474.   if not Assigned(FPathIsRelative) then
  475.   begin
  476.     FPathIsRelative := GetProcAddress(ShlwAPI, {$IFDEF UNICODE}'PathIsRelativeW'{$ELSE}'PathIsRelativeA'{$ENDIF});
  477.     Win32Check(Assigned(FPathIsRelative));
  478.   end;
  479.  
  480.   Result := FPathIsRelative(PChar(APath));
  481. end;
  482.  
  483. function PathIsAbsolute(const APath: String): Boolean;
  484. begin
  485.   Result := not PathIsRelative(APath);
  486. end;
  487.  
  488. var
  489.   FKernelLib: HMODULE;
  490.   FShlwAPILib: HMODULE;
  491.  
  492. function Kernel32: HMODULE;
  493. const
  494.   DLLName = 'kernel32.dll';
  495. begin
  496.   if FKernelLib = 0 then
  497.   begin
  498.     FKernelLib := LoadLibrary(DLLName);
  499.     Win32Check(FKernelLib <> 0);
  500.   end;
  501.   Result := FKernelLib;
  502. end;
  503.  
  504. function ShlwAPI: HMODULE;
  505. const
  506.   DLLName = 'shlwapi.dll';
  507. begin
  508.   if FShlwAPILib = 0 then
  509.   begin
  510.     FShlwAPILib := LoadLibrary(DLLName);
  511.     Win32Check(FShlwAPILib <> 0);
  512.   end;
  513.   Result := FShlwAPILib;
  514. end;
  515.  
  516. end.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement