(*
* 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;
interface
uses
Windows, SysUtils, Classes, Messages, SyncObjs;
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:
string
)
of object;
TDirectoryWatch =
class
private
FWatchOptions : TWatchOptions;
FWatchActions : TWatchActions;
FWatchSubTree : Boolean;
FWatchThread : TThread;
FWndHandle : HWND;
FDirectory :
string;
FAbortEvent : Cardinal;
FOnChange : TNotifyEvent;
FOnNotify : TFileChangeNotifyEvent;
procedure WatchWndProc(
var Msg: TMessage);
procedure SetDirectory(
const Value:
string);
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:
string
);
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:
string 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 :
string;
FIOResult : Pointer;
FFilter : Integer;
protected
procedure Execute;
override;
public
constructor Create(
const Directory:
string;
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(DWORD(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:
string;
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
raise Exception.CreateFmt(cErrorCreateWatchError, [Directory, GetLastError]);
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
CloseHandle(FDirHandle);
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);
CloseHandle(FAbortEvent);
// 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:
string);
begin
if StrIComp(PChar(Trim(Value)), PChar(FDirectory)) <> 0
then
begin
FDirectory := Trim(Value);
if Running
then
RestartWatchThread;
Change;
end;
end;
procedure TDirectoryWatch.Change;
begin
if Assigned(FOnChange)
then
FOnChange(Self);
end;
procedure TDirectoryWatch.Notify(
const Action: Integer;
const FileName:
string);
begin
if Assigned(FOnNotify)
then
if TWatchAction(Action - 1)
in FWatchActions
then
FOnNotify(Self, TWatchAction(Action - 1), FileName);
end;
end.