(*
* This software is distributed under BSD license.
*
* Copyright (c) 2009 Iztok Kacin, Cromis (iztok.kacin@gmail.com).
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without modification,
* are permitted provided that the following conditions are met:
*
* - Redistributions of source code must retain the above copyright notice, this
* list of conditions and the following disclaimer.
* - Redistributions in binary form must reproduce the above copyright notice, this
* list of conditions and the following disclaimer in the documentation and/or
* other materials provided with the distribution.
* - Neither the name of the Iztok Kacin nor the names of its contributors may be
* used to endorse or promote products derived from this software without specific
* prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
* ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
* IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
* INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
* BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
* DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
* OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
* OF THE POSSIBILITY OF SUCH DAMAGE.
*
* NOTICE OF CODE ORIGIN
*
* This code was derived from the original code of author "Gleb Yourchenko"
* The original code "FnugryDirWatch" can still be found at Torry Components
* The URL is: http://www.torry.net/pages.php?id=252
*
* The code was taken as a starting point and then mainly written from scratch
* keeping some of the healthy code parts. So I am not in any way an author of
* the original idea. But I am the author of all the changes and new code parts.
*
* ============================================================================
* 12/10/2009 (1.0.0)
* - Initial code rewrite from "FnugryDirWatch"
* 16/01/2010 (1.0.1)
* - Refactored the main watch loop
* ============================================================================
*)
unit DirectoryWatch;
{$MODE Delphi}
{$WARN 5057 off : Local variable "$1" does not seem to be initialized}
interface
uses
Windows, LCLIntf, LCLType, LMessages, SysUtils, FileUtil, Classes, Messages,
SyncObjs, RDCWProcessMonitor, RDCWDirMonitor;
const
FILE_NOTIFY_CHANGE_FILE_NAME = $00000001;
FILE_NOTIFY_CHANGE_DIR_NAME = $00000002;
FILE_NOTIFY_CHANGE_ATTRIBUTES = $00000004;
FILE_NOTIFY_CHANGE_SIZE = $00000008;
FILE_NOTIFY_CHANGE_LAST_WRITE = $00000010;
FILE_NOTIFY_CHANGE_LAST_ACCESS = $00000020;
FILE_NOTIFY_CHANGE_CREATION = $00000040;
FILE_NOTIFY_CHANGE_SECURITY = $00000100;
const
cShutdownTimeout = 3000;
type
// the filters that control when the watch is triggered
TWatchOption = (woFileName, woDirName, woAttributes, woSize, woLastWrite,
woLastAccess, woCreation, woSecurity);
TWatchOptions = set of TWatchOption;
// the actions that are the result of the watch being triggered
TWatchAction = (waAdded, waRemoved, waModified, waRenamedOld, waRenamedNew);
TWatchActions = set of TWatchAction;
TFileChangeNotifyEvent = procedure(const Sender: TObject;
const Action: TWatchAction;
const FileName: widestring
) of object;
TDirectoryWatch = class
private
FWatchOptions : TWatchOptions;
FWatchActions : TWatchActions;
FWatchSubTree : Boolean;
FWatchThread : TThread;
FWndHandle : HWND;
FDirectory : widestring;
FAbortEvent : Cardinal;
FOnChange : TNotifyEvent;
FOnNotify : TFileChangeNotifyEvent;
procedure WatchWndProc(var Msg: TMessage);
procedure SetDirectory(const Value: widestring);
procedure SetWatchOptions(const Value: TWatchOptions);
procedure SetWatchActions(const Value: TWatchActions);
procedure SetWatchSubTree(const Value: Boolean);
procedure DeallocateHWnd(Wnd: HWND);
function MakeFilter: Integer;
protected
procedure Change; virtual;
procedure AllocWatchThread;
procedure ReleaseWatchThread;
procedure RestartWatchThread;
procedure Notify(const Action: Integer;
const FileName: widestring
); virtual;
public
constructor Create;
destructor Destroy; override;
procedure Start;
procedure Stop;
function Running: Boolean;
property WatchSubTree: Boolean read FWatchSubTree write SetWatchSubTree;
property WatchOptions: TWatchOptions read FWatchOptions write SetWatchOptions;
property WatchActions: TWatchActions read FWatchActions write SetWatchActions;
property Directory: widestring read FDirectory write SetDirectory;
// notification properties. Notify about internal and exernal changes
property OnNotify: TFileChangeNotifyEvent read FOnNotify write FOnNotify;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
implementation
type
PFILE_NOTIFY_INFORMATION = ^TFILE_NOTIFY_INFORMATION;
TFILE_NOTIFY_INFORMATION = record
NextEntryOffset : Cardinal;
Action : Cardinal;
FileNameLength : Cardinal;
FileName : array[0..MAX_PATH - 1] of WideChar;
end;
const
WM_DIRWATCH_ERROR = WM_USER + 137;
WM_DIRWATCH_NOTIFY = WM_USER + 138;
FILE_LIST_DIRECTORY = $0001;
const
// error messages
cErrorInWatchThread = 'Error "%s" in watch thread. Error code: %d';
cErrorCreateWatchError = 'Error trying to create file handle for "%s". Error code: %d';
const
IO_BUFFER_LEN = 32 * SizeOf(TFILE_NOTIFY_INFORMATION);
type
TDirWatchThread = class(TThread)
private
FWatchSubTree : Boolean;
FAbortEvent : Cardinal;
FChangeEvent : Cardinal;
FWndHandle : Cardinal;
FDirHandle : Cardinal;
FDirectory : widestring;
FIOResult : Pointer;
FFilter : Integer;
protected
procedure Execute; override;
public
constructor Create(const Directory: widestring;
const WndHandle: Cardinal;
const AbortEvent: Cardinal;
const TypeFilter: Cardinal;
const aWatchSubTree: Boolean);
destructor Destroy; override;
end;
procedure TDirWatchThread.Execute;
var
NotifyData: PFILE_NOTIFY_INFORMATION;
Events: array[0..1] of THandle;
WaitResult: DWORD;
NextEntry: Integer;
ErrorMsg: PWideChar;
FileName: PWideChar;
Overlap: TOverlapped;
ResSize: Cardinal;
begin
FillChar(Overlap, SizeOf(TOverlapped), 0);
Overlap.hEvent := FChangeEvent;
// set the array of events
Events[0] := FChangeEvent;
Events[1] := FAbortEvent;
while not Terminated do
try
if ReadDirectoryChangesW(FDirHandle, FIOResult, IO_BUFFER_LEN, FWatchSubtree, FFilter, @ResSize, @Overlap, nil) then
begin
WaitResult := WaitForMultipleObjects(2, @Events[0], FALSE, INFINITE);
// check if we have terminated the thread
if WaitResult <> WAIT_OBJECT_0 then
begin
Terminate;
Exit;
end;
if WaitResult = WAIT_OBJECT_0 then
begin
NotifyData := FIOResult;
repeat
NextEntry := NotifyData^.NextEntryOffset;
// get memory for filename and fill it with data
GetMem(FileName, NotifyData^.FileNameLength + 2);
Move(NotifyData^.FileName, Pointer(FileName)^, NotifyData^.FileNameLength);
PWord(Cardinal(FileName) + NotifyData^.FileNameLength)^ := 0;
// send the message about the filename information and advance to the next entry
PostMessage(FWndHandle, WM_DIRWATCH_NOTIFY, NotifyData^.Action, LParam(FileName));
Inc(NotifyData, NextEntry);
until (NextEntry = 0);
end;
end;
except
on E :Exception do
begin
GetMem(ErrorMsg, Length(E.Message) + 2);
Move(E.Message, Pointer(ErrorMsg)^, Length(E.Message));
PWord(Cardinal(ErrorMsg) + Cardinal(Length(E.Message)))^ := 0;
PostMessage(FWndHandle, WM_DIRWATCH_ERROR, GetLastError, LPARAM(ErrorMsg));
end;
end;
end;
constructor TDirWatchThread.Create(const Directory: widestring;
const WndHandle: Cardinal;
const AbortEvent: Cardinal;
const TypeFilter: Cardinal;
const aWatchSubTree: Boolean);
begin
//
// Retrieve proc pointer, open directory to
// watch and allocate buffer for notification data.
// (note, it is done before calling inherited
// create (that calls BeginThread) so any exception
// will be still raised in caller's thread)
//
FDirHandle := CreateFile(PChar(Directory),
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);
//if FDirHandle = INVALID_HANDLE_VALUE then
//begin
// raise Exception.CreateFmt(cErrorCreateWatchError, [Directory, GetLastError]);
//end;
FChangeEvent := CreateEvent(nil, FALSE, FALSE, nil);
FAbortEvent := AbortEvent;
// allocate the buffer memory
GetMem(FIOResult, IO_BUFFER_LEN);
FWatchSubTree := aWatchSubtree;
FWndHandle := WndHandle;
FDirectory := Directory;
FFilter := TypeFilter;
// make sure we free the thread
FreeOnTerminate := True;
inherited Create(False);
end;
destructor TDirWatchThread.Destroy;
begin
//if FDirHandle <> INVALID_HANDLE_VALUE then
// FileClose(FDirHandle); { *Konvertiert von CloseHandle* }
if Assigned(FIOResult) then
FreeMem(FIOResult);
inherited Destroy;
end;
{ TFnugryDirWatch }
procedure TDirectoryWatch.AllocWatchThread;
begin
if FWatchThread = nil then
begin
FAbortEvent := CreateEvent(nil, FALSE, FALSE, nil);
FWatchThread := TDirWatchThread.Create(Directory,
FWndHandle,
FAbortEvent,
MakeFilter,
WatchSubtree);
end;
end;
procedure TDirectoryWatch.ReleaseWatchThread;
var
AResult: Cardinal;
begin
if FWatchThread <> nil then
begin
// set and close event
SetEvent(FAbortEvent);
FileClose(FAbortEvent); { *Konvertiert von CloseHandle* }
// wait and block until thread is finished
AResult := WaitForSingleObject(FWatchThread.Handle, cShutdownTimeout);
// check if we timed out
if AResult = WAIT_TIMEOUT then
TerminateThread(FWatchThread.Handle, 0);
FWatchThread := nil;
end;
end;
procedure TDirectoryWatch.RestartWatchThread;
begin
Stop;
Start;
end;
function TDirectoryWatch.Running: Boolean;
begin
Result := FWatchThread <> nil;
end;
procedure TDirectoryWatch.DeallocateHWnd(Wnd: HWND);
var
Instance: Pointer;
begin
Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC));
if Instance <> @DefWindowProc then
begin
{ make sure we restore the default
windows procedure before freeing memory }
SetWindowLong(Wnd, GWL_WNDPROC, Longint(@DefWindowProc));
FreeObjectInstance(Instance);
end;
DestroyWindow(Wnd);
end;
destructor TDirectoryWatch.Destroy;
begin
Stop;
DeallocateHWnd(FWndHandle);
inherited Destroy;
end;
constructor TDirectoryWatch.Create;
begin
FWndHandle := AllocateHWnd(WatchWndProc);
FWatchSubtree := True;
// construct the default watch actions and options
FWatchActions := [waAdded]; //, waRemoved, waModified, waRenamedOld, waRenamedNew];
FWatchOptions := [woFileName, woDirName, woAttributes, woSize, woLastWrite,
woLastAccess, woCreation, woSecurity];
end;
procedure TDirectoryWatch.SetWatchActions(const Value: TWatchActions);
begin
if FWatchActions <> Value then
begin
FWatchActions := Value;
if Running then
RestartWatchThread;
Change;
end;
end;
procedure TDirectoryWatch.SetWatchOptions(const Value: TWatchOptions);
begin
if FWatchOptions <> Value then
begin
FWatchOptions := Value;
if Running then
RestartWatchThread;
Change;
end;
end;
procedure TDirectoryWatch.WatchWndProc(var Msg :TMessage);
var
ErrorCode: Cardinal;
ErrorMessage: string;
begin
case Msg.msg of
WM_DIRWATCH_NOTIFY:
//
// Retrieve notify data and forward
// the event to TDirectoryWatch's notify
// handler. Free filename string (allocated
// in WatchThread's notify handler.)
//
begin
try
Notify(Msg.wParam, WideCharToString(PWideChar(Msg.lParam)));
finally
if Msg.lParam <> 0 then
FreeMem(Pointer(Msg.lParam));
end;
end;
WM_DIRWATCH_ERROR:
//
// Disable dir watch and re-raise
// exception on error
//
begin
try
ErrorMessage := WideCharToString(PWideChar(Msg.lParam));
ErrorCode := Msg.WParam;
Stop;
raise Exception.CreateFmt(cErrorInWatchThread, [ErrorMessage, ErrorCode]);
finally
if Msg.lParam <> 0 then
FreeMem(Pointer(Msg.lParam));
end;
end;
//
// pass all other messages down the line
//
else
begin
Msg.Result := DefWindowProc(FWndHandle, Msg.Msg, Msg.wParam, Msg.lParam);
Exit;
end;
end;
end;
function TDirectoryWatch.MakeFilter: Integer;
const
FilterFlags: array [TWatchOption] of Integer = (FILE_NOTIFY_CHANGE_FILE_NAME,
FILE_NOTIFY_CHANGE_DIR_NAME,
FILE_NOTIFY_CHANGE_ATTRIBUTES,
FILE_NOTIFY_CHANGE_SIZE,
FILE_NOTIFY_CHANGE_LAST_WRITE,
FILE_NOTIFY_CHANGE_LAST_ACCESS,
FILE_NOTIFY_CHANGE_CREATION,
FILE_NOTIFY_CHANGE_SECURITY);
var
Flag: TWatchOption;
begin
Result := 0;
for Flag in FWatchOptions do
Result := Result or FilterFlags[Flag];
end;
procedure TDirectoryWatch.SetWatchSubTree(const Value :Boolean);
begin
if Value <> FWatchSubtree then
begin
FWatchSubtree := Value;
if Running then
RestartWatchThread;
Change;
end;
end;
procedure TDirectoryWatch.Start;
begin
if FDirectory = '' then
raise Exception.Create('Please specify a directory to watch');
if not Running then
begin
AllocWatchThread;
Change;
end;
end;
procedure TDirectoryWatch.Stop;
begin
if Running then
begin
ReleaseWatchThread;
Change;
end;
end;
procedure TDirectoryWatch.SetDirectory(const Value: widestring);
begin
if StrIComp(PChar(Trim(Value)), PChar(FDirectory)) <> 0 then
begin
FDirectory := Trim(Value);
if Running then
begin
RestartWatchThread;
end;
Change;
end;
end;
procedure TDirectoryWatch.Change;
begin
if Assigned(FOnChange) then
begin
FOnChange(Self);
end;
end;
procedure TDirectoryWatch.Notify(const Action: Integer; const FileName: widestring);
begin
if Assigned(FOnNotify) then
if TWatchAction(Action - 1) in FWatchActions then
FOnNotify(Self, TWatchAction(Action - 1), FileName);
end;
end.