unit wfsU;

{$WARN SYMBOL_PLATFORM OFF}

interface

uses
  Windows, SysUtils, Classes, ActiveX;

type
  // Структура с информацией об изменении в файловой системе (передается в callback процедуру)
  PInfoCallback = ^TFileNotifyInfo;
  TFileNotifyInfo = record
    Action      : Integer; // тип изменения (константы FILE_ACTION_XXX)
    Path        : string;  // путь, по которому было изменение
    OldFileName : string;  // имя файла до переименования
    NewFileName : string;  // имя файла после переименования
  end;

  // callback процедура, вызываемая при изменении в файловой системе
  TWatchFileSystemCallback = procedure (const AInfo: TFileNotifyInfo) of object;

  TWFS = class(TThread)
  private
    FPath           : string;
    FFilter         : Cardinal;
    FSubTree        : Boolean;
    FInfoCallback   : TWatchFileSystemCallback;

    FWatchHandle    : THandle;
    FCompletionPort : THandle;
    FOldFileName    : string;
  private
    procedure HandleEvent(AFileNotifyInfo: Pointer);
  protected
    procedure Execute; override;
    procedure DoProcess;
  public
  { Запуск мониторинга файловой системы
  Праметры:
    APath    - имя папки для мониторинга
    AFilter  - комбинация констант FILE_NOTIFY_XXX
    ASubTree - мониторить ли все подпапки заданной папки
    AInfoCallback - адрес callback процедуры, вызываемой при изменении в файловой системе}
    constructor Create(const APath: string; AFilter: Cardinal; ASubTree: Boolean;
      AInfoCallback: TWatchFileSystemCallback);
    destructor Destroy; override;
    procedure Stop;
  end;

function TestFileAccess(const AFileName: string): Cardinal;

implementation

uses
  UThreads;

const
  FILE_LIST_DIRECTORY   = $0001;

type
  {$IF not Declared(ULONG_PTR)}
    {$IFDEF CPUX64}
    ULONG_PTR = UInt64;
    {$ELSE}
    ULONG_PTR = Cardinal;
    {$ENDIF}
  {$IFEND}

  PFileNotifyInformation = ^TFileNotifyInformation;
  TFileNotifyInformation = record
     NextEntryOffset : DWORD;
     Action          : DWORD;
     FileNameLength  : DWORD;
     FileName        : array[0..0] of WideChar;
  end;

function TestFileAccess(const AFileName: string): Cardinal;
var
  LHandle: THandle;
begin
  LHandle := CreateFile(PChar(AFileName), GENERIC_READ, FILE_SHARE_READ, nil,
    OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if LHandle <> INVALID_HANDLE_VALUE then begin
    CloseHandle(LHandle);
    Result := 0;
  end else
    Result := GetLastError;
end;

{ TWFS }

constructor TWFS.Create(const APath: string; AFilter: Cardinal; ASubTree: Boolean;
  AInfoCallback: TWatchFileSystemCallback);
begin
  inherited Create(False);
  {$IFOPT D+}
  NameThreadForDebugging('TWFS', ThreadID);
  {$ENDIF}
  TThreadNamesManager.SetThreadMapName(Format('%s.%s', [ExtractFileName(GetModuleName(HInstance)), ClassName]), ThreadID);
  FreeOnTerminate := True;
  FPath := IncludeTrailingPathDelimiter(APath);
  FFilter := AFilter;
  FSubTree := ASubTree;
  FOldFileName := EmptyStr;
  FInfoCallback := AInfoCallback;

  FWatchHandle:=CreateFile(PChar(FPath), FILE_LIST_DIRECTORY,
    FILE_SHARE_READ or FILE_SHARE_DELETE or FILE_SHARE_WRITE, nil,
    OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS or FILE_FLAG_OVERLAPPED, 0);
  Win32Check(FWatchHandle <> INVALID_HANDLE_VALUE);
  FCompletionPort := CreateIoCompletionPort(FWatchHandle, 0, Longint(Pointer(Self)), 0);
  Win32Check(LongBool(FCompletionPort));
end;

destructor TWFS.Destroy;
begin
  PostQueuedCompletionStatus(FCompletionPort, 0, 0, nil);
  CloseHandle(FCompletionPort);
  CloseHandle(FWatchHandle);
  TThreadNamesManager.RemoveThreadMapName(ThreadID);
  inherited Destroy;
end;

procedure TWFS.Execute;
begin
  CoInitializeEx(nil, COINIT_MULTITHREADED or COINIT_SPEED_OVER_MEMORY);
  try
    DoProcess;
  finally
    CoUninitialize;
  end;
end;

procedure TWFS.DoProcess;
const
  CWatchBufSize = 1024 * 1024;
var
  LCompletionKey: ULONG_PTR;
  LOverlapped: TOverlapped;
  LOverlappedPtr: POverlapped;
  LWatchBuf: Pointer;
  LBytesWrite: DWORD;
  LNumBytes: Cardinal;
begin
  {$OPTIMIZATION ON}
  LOverlappedPtr := @LOverlapped;
  FillChar(LOverlapped, SizeOf(LOverlapped), 0);
  GetMem(LWatchBuf, CWatchBufSize);
  try
    while not Terminated do begin
      FillChar(LWatchBuf^, CWatchBufSize, 0);
      LBytesWrite := 0;
      Win32Check(ReadDirectoryChangesW(FWatchHandle, LWatchBuf, CWatchBufSize,
        FSubTree, FFilter, @LBytesWrite, LOverlappedPtr, nil));
      GetQueuedCompletionStatus(FCompletionPort, LNumBytes, LCompletionKey, LOverlappedPtr, INFINITE);
      if LCompletionKey <> 0 then
        HandleEvent(LWatchBuf)
      else
        Terminate;
    end;
  finally
    FreeMem(LWatchBuf);
  end;
end;

procedure TWFS.HandleEvent(AFileNotifyInfo: Pointer);
var
  LFileNotifyInfo: PFileNotifyInformation absolute AFileNotifyInfo;
  LInfoCallback: TFileNotifyInfo;
  LOffset: DWORD;
begin
  repeat
    LInfoCallback.Action := LFileNotifyInfo^.Action;
    LInfoCallback.Path := FPath;
    LInfoCallback.NewFileName := WideCharLenToString(
      @LFileNotifyInfo^.FileName[0], LFileNotifyInfo^.FileNameLength shr 1);
    case LFileNotifyInfo^.Action of
      FILE_ACTION_RENAMED_OLD_NAME: FOldFileName := LInfoCallback.NewFileName;
      FILE_ACTION_RENAMED_NEW_NAME: begin
        LInfoCallback.OldFileName := FOldFileName;
        FOldFileName := EmptyStr;
      end;
    end;
    FInfoCallback(LInfoCallback);
    LOffset := LFileNotifyInfo^.NextEntryOffset;
    LFileNotifyInfo := PFileNotifyInformation(ULONG_PTR(LFileNotifyInfo) + LOffset);
  until (LOffset = 0) or Terminated;
end;

procedure TWFS.Stop;
var
  LPID: THandle;
  LHandle: THandle;
begin
  LPID := GetCurrentProcess;
  Win32Check(DuplicateHandle(LPID, Handle, LPID, @LHandle, 0, False, DUPLICATE_SAME_ACCESS));
  try
    Terminate;
    Win32Check(PostQueuedCompletionStatus(FCompletionPort, 0, 0, nil));
    Win32Check(WaitForSingleObject(LHandle, INFINITE) <> WAIT_FAILED);
  finally
    CloseHandle(LHandle);
  end;
end;

end.