Как заблокировать каталог в приложении на Delphi или Pascal под Windows 10/11 64-бит?

Delphi , Файловая система , Директории

Блокировка каталога в приложениях Delphi/Pascal под Windows 10/11 64-бит

Введение

При разработке приложений на Delphi или Free Pascal (FPC) иногда возникает необходимость заблокировать каталог для исключительного использования вашим приложением. Это особенно важно, когда ваша программа работает с временными файлами или конфиденциальными данными, которые не должны быть доступны другим процессам.

В этой статье мы рассмотрим несколько подходов к блокировке каталогов в Windows 10/11 64-бит с использованием Object Pascal.

Основные методы блокировки каталогов

1. Использование CreateFile с FILE_FLAG_BACKUP_SEMANTICS

Самый простой способ заблокировать каталог - использовать API функцию CreateFile с флагом FILE_FLAG_BACKUP_SEMANTICS:

program LockDirectoryExample;
{$mode objfpc}{$H+}
uses
  Windows, SysUtils;

var
  hDir: THandle;
  DirPath: string;

begin
  DirPath := 'C:\TestLock'; // Укажите путь к вашему каталогу

  // Пытаемся заблокировать каталог
  hDir := CreateFile(
    PChar(DirPath),
    0,                 // Нет доступа, только блокировка
    0,                 // Эксклюзивный режим (без совместного доступа)
    nil,
    OPEN_EXISTING,
    FILE_FLAG_BACKUP_SEMANTICS,
    0
  );

  if hDir = INVALID_HANDLE_VALUE then
  begin
    Writeln('Ошибка блокировки каталога: ', SysErrorMessage(GetLastError));
    Exit;
  end;

  try
    Writeln('Каталог успешно заблокирован. Приложение работает...');
    // Здесь ваш основной код приложения
    Readln; // Пауза для демонстрации
  finally
    // Разблокировать каталог закрытием handle
    CloseHandle(hDir);
    Writeln('Каталог разблокирован.');
  end;
end.

2. Усовершенствованный метод с ACL (Access Control List)

Для более надежной блокировки можно использовать списки контроля доступа:

uses
  Windows, SysUtils, JwaWinNT, JwaAccCtrl, JwaAclApi;

function LockDirectoryWithACL(const DirPath: string): Boolean;
var
  hDir: THandle;
  pSD: PSECURITY_DESCRIPTOR;
  pDACL: PACL;
  ea: EXPLICIT_ACCESS_W;
  dwRes: DWORD;
begin
  Result := False;

  // Создаем пустой DACL (Deny Access Control List)
  pSD := nil;
  try
    // Создаем security descriptor
    pSD := PSECURITY_DESCRIPTOR(LocalAlloc(LPTR, SECURITY_DESCRIPTOR_MIN_LENGTH));
    if not InitializeSecurityDescriptor(pSD, SECURITY_DESCRIPTOR_REVISION) then
      Exit;

    // Создаем пустой DACL (запрещаем все)
    if not SetSecurityDescriptorDacl(pSD, True, nil, False) then
      Exit;

    // Устанавливаем атрибуты безопасности
    ea.grfAccessPermissions := 0; // Нет прав
    ea.grfAccessMode := DENY_ACCESS;
    ea.grfInheritance := SUB_CONTAINERS_AND_OBJECTS_INHERIT;
    ea.Trustee.TrusteeForm := TRUSTEE_IS_NAME;
    ea.Trustee.TrusteeType := TRUSTEE_IS_USER;
    ea.Trustee.ptstrName := 'CURRENT_USER';

    // Применяем ACL к каталогу
    dwRes := SetNamedSecurityInfo(
      PChar(DirPath),
      SE_FILE_OBJECT,
      DACL_SECURITY_INFORMATION,
      nil, nil, nil, nil
    );

    Result := (dwRes = ERROR_SUCCESS);
  finally
    if pSD <> nil then
      LocalFree(HLOCAL(pSD));
  end;
end;

Решение проблемы с "зависанием" приложения

В исходном вопросе пользователь столкнулся с проблемой, когда его приложение "зависало". Основная причина - использование ANSI строк вместо Unicode в Windows API функциях. Вот исправленная версия:

constructor TFileLockerThread.Create(const DirPath: string);
begin
  inherited Create(False);
  FreeOnTerminate := False;

  FDirPath := IncludeTrailingPathDelimiter(DirPath);
  InitializeCriticalSection(FLock);

  // Используем WideString для Unicode поддержки
  FDirHandle := CreateFileW(
    PWideChar(WideString(FDirPath)),
    FILE_LIST_DIRECTORY,
    FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE,
    nil,
    OPEN_EXISTING,
    FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OVERLAPPED,
    0
  );

  if FDirHandle = INVALID_HANDLE_VALUE then
    raise Exception.CreateFmt('Ошибка: не удалось открыть каталог.' + #10 +
      'Код ошибки: %d', [GetLastError]);
end;

Альтернативное решение: использование мьютексов

Для простой блокировки каталога можно использовать именованные мьютексы:

var
  hMutex: THandle;

// При запуске приложения
hMutex := CreateMutex(nil, True, 'Global\MyAppDirectoryLock');
if GetLastError = ERROR_ALREADY_EXISTS then
begin
  // Каталог уже заблокирован другим экземпляром приложения
  MessageBox(0, 'Приложение уже запущено!', 'Ошибка', MB_ICONERROR);
  Halt(1);
end;

// При завершении приложения
ReleaseMutex(hMutex);
CloseHandle(hMutex);

Удаление заблокированного каталога

Для удаления заблокированного каталога можно использовать рекурсивную функцию:

function DeleteDirectory(const Path: string): Boolean;
var
  SearchRec: TSearchRec;
begin
  Result := False;
  if FindFirst(Path + '\*.*', faAnyFile, SearchRec) = 0 then
  try
    repeat
      if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
      begin
        if (SearchRec.Attr and faDirectory) <> 0 then
          DeleteDirectory(Path + '\' + SearchRec.Name)
        else
          DeleteFile(Path + '\' + SearchRec.Name);
      end;
    until FindNext(SearchRec) <> 0;
  finally
    FindClose(SearchRec);
  end;
  Result := RemoveDir(Path);
end;

Заключение

Блокировка каталога в приложениях Delphi/Pascal под Windows требует внимательного подхода. Мы рассмотрели несколько методов:

1. Простое блокирование через CreateFile с FILE_FLAG_BACKUP_SEMANTICS
2. Более надежное решение через ACL
3. Альтернативный подход с мьютексами
4. Методы рекурсивного удаления каталогов

Для большинства случаев достаточно первого метода, но если требуется более строгий контроль доступа, стоит рассмотреть вариант с ACL. Всегда учитывайте Unicode-совместимость при работе с Windows API и не забывайте освобождать ресурсы (handles) при завершении работы приложения.

Приведенные примеры кода можно адаптировать под конкретные требования вашего проекта, добавляя обработку ошибок и дополнительные проверки безопасности.

Создано по материалам из источника по ссылке.

Методы блокировки каталогов в приложениях Delphi/Pascal под Windows 10/11 64-бит с использованием API функций, ACL и мьютексов для обеспечения безопасности данных.

Комментарии и вопросы

Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш Telegram-канал delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS

:: Главная :: Директории ::