While reading up on Win64 structured exception tracing (from Programming against the x64 exception handling support, part 7: Putting it all together, or building a stack walk routine), I converted the code StackWalk64.cpp.
procedure DumpExceptionStack();
var
LContext : CONTEXT;
LUnwindHistoryTable : _UNWIND_HISTORY_TABLE;
LRuntimeFunction : Pointer;
LImageBase : ULONGLONG;
HandlerData : Pointer;
EstablisherFrame : ULONG64;
NvContext : KNONVOLATILE_CONTEXT_POINTERS;
LLineNumber : integer;
LModuleName : UnicodeString;
LPublicAddr : pointer;
LPublicName : UnicodeString;
LUnitName : UnicodeString;
begin
//
// First, we'll get the caller's context.
//
RtlCaptureContext(LContext);
//
// Initialize the (optional) unwind history table.
//
LUnwindHistoryTable := Default(_UNWIND_HISTORY_TABLE);
// LUnwindHistoryTable.Unwind := True;
//
// This unwind loop intentionally skips the first call frame, as it shall
// correspond to the call to StackTrace64, which we aren't interested in.
//
repeat
//
// Try to look up unwind metadata for the current function.
//
LRuntimeFunction := RtlLookupFunctionEntry(LContext.Rip,
LImageBase,
LUnwindHistoryTable);
NvContext := Default(KNONVOLATILE_CONTEXT_POINTERS);
if not Assigned(LRuntimeFunction) then
begin
//
// If we don't have a RUNTIME_FUNCTION, then we've encountered
// a leaf function. Adjust the stack approprately.
//
//LContext.Rip := (ULONG64)(*(PULONG64)Context.Rsp);
LContext.Rip := ULONG64(Pointer(LContext.Rsp)^);
LContext.Rsp := LContext.Rsp + 8;
end
else
begin
//
// Otherwise, call upon RtlVirtualUnwind to execute the unwind for
// us.
//
RtlVirtualUnwind(UNW_FLAG_NHANDLER,
LImageBase,
LContext.Rip,
LRuntimeFunction,
LContext,
HandlerData,
EstablisherFrame,
NvContext);
end;
//
// If we reach an RIP of zero, this means that we've walked off the end
// of the call stack and are done.
//
if LContext.Rip = 0 then
Break;
//
// Display the context. Note that we don't bother showing the XMM
// context, although we have the nonvolatile portion of it.
//
if madMapFile.GetMapFileInfos(Pointer(LContext.Rip),
LModuleName,
LUnitName,
LPublicName,
LPublicAddr,
LLineNumber) then
begin
Writeln(Format('%p %s.%s %d', [Pointer(LContext.Rip), LUnitName, LPublicName, LLineNumber{, LSEHType}]));
end;
until LContext.Rip = 0;
end;
Then I call it with the following:
procedure Main();
begin
try
try
try
try
DumpExceptionStack();
finally
//
end;
except
on E : Exception do
raise
end;
except
on E : Exception do
raise
end;
except
on E : Exception do
raise
end;
end;
When I run the application (just a console application), I only get one entry for Main but I was expecting there to be four (three nested exceptions and one finally).
Could it be that I have mis-interpretted and that DumpExceptionStack will only give the result that I am interested in when an exception is thrown? If this is so, what would the required changes be to get all the exception stacks (if it possible) - ie. have four outputs for Main ?
The x64 exception model is table based, in contrast to the stack based x86 model. Which means that exception stacks do not exist. In any case, I've never seen a stalk walk routine that attempts to include exception and finally blocks. This one is no different. It walks the function call stack.
The exception flow within a single function is controlled by the scope tables. In your function, if your code raised an exception at the point at which is calls DumpExceptionStack, then multiple scope table entries match the exception location. The exception is handled by the innermost matching scope. The distance between the scope's begin and end addresses can be used to infer which scope is the innermost. If that innermost scope does not handle the exception, or re-raises it, then the next most innermost scope is asked to handle it. And so on until all the matching scopes for the function are exhausted.
Related
I have this code (that runs under iOS with Delphi Tokyo):
procedure TMainForm.Button1Click(Sender: TObject);
var aData: NSData;
begin
try
try
aData := nil;
finally
// this line triggers an exception
aData.release;
end;
except
on E: Exception do begin
exit;
end;
end;
end;
Normally the exception should be caught in the except end block, but in this case it is not caught by the handler and it is propagated to the Application.OnException handler.
Access violation at address 0000000100EE9A8C, accessing address
0000000000000000
Did I miss something?
This is a bug (actually, a feature) on iOS and Android platforms (possibly on others with LLVM backend - though they are not explicitly documented).
Core issue is that exception caused by virtual method call on nil reference constitutes hardware exception that is not captured by nearest exception handler and it is propagated to the next exception handler (in this case to Application exception handler).
Use a Function Call in a try-except Block to Prevent Uncaught Hardware Exceptions
With compilers for iOS devices, except blocks can catch a hardware
exception only if the try block contains a method or function call.
This is a difference related to the LLVM backend of the compiler,
which cannot return if no method/function is called in the try block.
The simplest code that exhibits the issue on iOS and Android platform is:
var
aData: IInterface;
begin
try
aData._Release;
except
end;
end;
Executing above code on Windows platform works as expected and the exception is caught by exception handler. There is no nil assignment in above code, because aData is interface reference and they are automatically nilled by compiler on all platforms. Adding nil assignment is redundant and does not change the outcome.
To show that exceptions are caused by virtual method calls
type
IFoo = interface
procedure Foo;
end;
TFoo = class(TInterfacedObject, IFoo)
public
procedure Foo; virtual;
end;
procedure TFoo.Foo;
var
x, y: integer;
begin
y := 0;
// division by zero causes exception here
x := 5 div y;
end;
In all following code variants, exception escapes exception handler.
var
aData: IFoo;
begin
try
aData.Foo;
except
end;
end;
var
aData: TFoo;
begin
try
aData.Foo;
except
end;
end;
Even if we change Foo method implementation and remove all code from it, it will still cause escaping exception.
If we change Foo declaration from virtual to static, exception caused by division to zero will be properly caught because call to static methods on nil references is allowed and call itself does not throw any exceptions - thus constitutes function call mentioned in documentation.
type
TFoo = class(TInterfacedObject, IFoo)
public
procedure Foo;
end;
TFoo = class(TObject)
public
procedure Foo;
end;
Another static method variant that also causes exception that is properly handled is declaring x as TFoo class field and accessing that field in Foo method.
TFoo = class(TObject)
public
x: Integer;
procedure Foo;
end;
procedure TFoo.Foo;
var
x: integer;
begin
x := 5;
end;
Back to the original question that involved NSData reference. NSData is Objective-C class and those are represented as interfaces in Delphi.
// root interface declaration for all Objective-C classes and protocols
IObjectiveC = interface(IInterface)
[IID_IObjectiveC_Name]
end;
Since calling methods on interface reference is always virtual call that goes through VMT table, in this case behaves in similar manner (exhibits same issue) as virtual method call invoked directly on object reference. The call itself throws an exception and is not caught by nearest exception handler.
Workarounds:
One of the workarounds in code where reference might be nil is checking it for nil before calling virtual method on it. If needed, in case of nil reference we can also raise regular exception that will be properly caught by enclosing exception handler.
var
aData: NSData;
begin
try
if Assigned(aData) then
aData.release
else
raise Exception.Create('NSData is nil');
except
end;
end;
Another workaround as mentioned in documentation is to put code in additional function (method)
procedure SafeCall(const aData: NSData);
begin
aData.release;
end;
var
aData: NSData;
begin
try
SafeCall(aData);
except
end;
end;
Just a question since I can't seem to find the answer somewhere else.
So I got an PL/SQL function which contains a nested block, and within the 2nd level block it got a return value of 1. Does this mean that it will not proceed to the next block and return the value 1 or it will only terminate the current block?
Thanks!
Sample structure for illustration:
FUNCTION EXAMPLE ( sample_variable VARCHAR2)
RETURN NUMBER
IS
BEGIN
BEGIN
/*CODES HERE*/
EXCEPTION
WHEN OTHERS THEN
RETURN 1; //HERE IS THE QUESTION. WHEN I GOT HERE IN RETURN DOES IT TERMINATE THE WHOLE
//FUNCTION AND RETURN 1 OR IT WILL STILL CONTINUE TO BLOCK 2*/
END;
BEGIN /*BLOCK 2*/
/*OTHER CODES HERE*/
RETURN 2;
END;
END
END EXAMPLE;
Terminates the whole function.
From oracle docs:
In a function, the RETURN statement assigns a specified value to the
function identifier and returns control to the invoker, where
execution resumes immediately after the invocation.
Starting from Way of getting control handle from TMessage question, I've created my own implementation in order to replace the Windowproc with my own one, in order to make some processing when mouse left button is pressed.
TOverrideMessage = class
public
FControl: TWinControl;
FOldWndProc: TWndMethod;
procedure OverrideWindowProc(var Message: TMessage);
end;
implementation:
procedure TOverrideMessage.OverrideWindowProc(var Message: TMessage);
begin
if Message.Msg = WM_NCLBUTTONDOWN then
begin
FOldWndProc(Message);
if FControl is TSomeCustomControl then
ShowMessage(TSomeCustomControl(FControl).Caption);//this property exists
end
else
Dispatch(Message);
end;
And replace the windowprocs of each of the controls I want with an instance of my class:
LOverrideMessage := TOverrideMessage.Create;
LOverrideMessage.FControl := TSomeCustomControl(lControl4);
LOverrideMessage.FOldWndProc := TWinControl(lControl4).WindowProc;
TWinControl(lControl4).WindowProc := LOverrideMessage.OverrideWindowProc;
The problem I have is that the messages are not dispatched correctly further to the controls so the controls are not drawing correctly,etc. Also I'm not receiving the WM_NCLBUTTONDOWN message in the class implementation. What's wrong?
Your main problem is the failure to call FOldWndProc. You need to call that rather than Dispatch. When you call Dispatch you will get the base TObject handling, which does nothing.
procedure TOverrideMessage.OverrideWindowProc(var Message: TMessage);
begin
FOldWndProc(Message);
if Message.Msg = WM_NCLBUTTONDOWN then
if FControl is TSomeCustomControl then
ShowMessage(TSomeCustomControl(FControl).Caption);//this property exists
end;
If WM_NCLBUTTONDOWN doesn't arrive, then the message is not being sent to your control.
I am concerned by your casting. When you write:
LOverrideMessage.FControl := TSomeCustomControl(lControl4);
LOverrideMessage.FOldWndProc := TWinControl(lControl4).WindowProc;
TWinControl(lControl4).WindowProc := LOverrideMessage.OverrideWindowProc;
why do you need any of those casts? If lControl4 was derived from TWinControl then you would not need those casts. If lControl4 has a compile time type that is less derived, then at least include an is check.
I have an application which can log a stacktrace, which can be later used for debugging.
On Windows, I've gotten by using the excellent JCLDebug unit provided by the JEDI project.
Now that my application is running on OSX, I've hit a bit of a hitch - I don't know how to obtain the correct stacktrace when an exception occurs.
I have got the basics down -
1) I can get a stacktrace using 'backtrace' (found in libSystem.dylib)
2) The resulting backtrace can be converted into line numbers using the .map file provided by Delphi's linker
The issue I'm left with is - I don't know where to call backtrace from. I know that Delphi uses Mach exceptions (on a separate thread), and that I cannot use posix signals, but that's all that I've managed to sort out.
I can get a backtrace in the 'try...except' block, but unfortunately, by that point the stack has already wound down.
How can I install a proper exception logger which will run right after the exception occurs?
Update:
As per 'Honza R's suggestion, I've taken a look at the 'GetExceptionStackInfoProc' procedure.
This function does get me 'inside' of the exception handling process, but unfortunately leaves me with some of the same issues I had previously.
First of all - on desktop platforms, this function 'GetExceptionStackInfoProc' is just a function pointer, which you can assign with your own exception info handler. So out of the box, Delphi doesn't provide any stack information provider.
If I assign a function to 'GetExceptionStackInfoProc' and then run a 'backtrace' inside of it, I receive a stacktrace, but that trace is relative to the exception handler, not the thread which caused the exception.
'GetExceptionStackInfoProc' does contain a pointer to a 'TExceptionRecord', but there's very limited documentation available on this.
I might be going beyond my depth, but how can I get a stacktrace from the correct thread? Would it be possible for me to inject my own 'backtrace' function into the exception handler and then return to the standard exception handler from there?
Update 2
Some more details. One thing to clear up - this question is about exceptions that are handled by MACH messages, not software exceptions that are handled entirely within the RTL.
Embarcadero has laid out some comments along with these functions -
System.Internal.MachExceptions.pas -> catch_exception_raise_state_identity
{
Now we set up the thread state for the faulting thread so that when we
return, control will be passed to the exception dispatcher on that thread,
and this POSIX thread will continue watching for Mach exception messages.
See the documentation at <code>DispatchMachException()</code> for more
detail on the parameters loaded in EAX, EDX, and ECX.
}
System.Internal.ExcUtils.pas -> SignalConverter
{
Here's the tricky part. We arrived here directly by virtue of our
signal handler tweaking the execution context with our address. That
means there's no return address on the stack. The unwinder needs to
have a return address so that it can unwind past this function when
we raise the Delphi exception. We will use the faulting instruction
pointer as a fake return address. Because of the fencepost conditions
in the Delphi unwinder, we need to have an address that is strictly
greater than the actual faulting instruction, so we increment that
address by one. This may be in the middle of an instruction, but we
don't care, because we will never be returning to that address.
Finally, the way that we get this address onto the stack is important.
The compiler will generate unwind information for SignalConverter that
will attempt to undo any stack modifications that are made by this
function when unwinding past it. In this particular case, we don't want
that to happen, so we use some assembly language tricks to get around
the compiler noticing the stack modification.
}
Which seem to be responsible for the issue I'm having.
When I do a stacktrace after this exception system has handed control over to the RTL, it looks like this - (bearing in mind, the stack unwinder has been superseded by a backtrace routine. The backtrace will hand control over to the unwinder once it is completed)
0: MyExceptionBacktracer
1: initunwinder in System.pas
2: RaiseSignalException in System.Internal.ExcUtils.pas
Since RaiseSignalException is called by SignalConverter, I'm led to believe that the backtrace function provided by libc is not compatible with the modifications made to the stack. So, it's incapable of reading the stack beyond that point, but the stack is still present underneath.
Does anyone know what to do about that (or whether my hypothesis is correct)?
Update 3
I've finally managed to get proper stacktraces on OSX. Huge thanks to both Honza and Sebastian. By combining both of their techniques, I found something that works.
For anyone else who could benefit from this, here's the basic source. Bear in mind that I'm not quite sure if it's 100% correct, if you can suggest improvements, go ahead. This technique hooks onto an exception right before Delphi unwinds the stack on the faulting thread, and compensates for any stack frame corruption that might have taken place beforehand.
unit MyExceptionHandler;
interface
implementation
uses
SysUtils;
var
PrevRaiseException: function(Exc: Pointer): LongBool; cdecl;
function backtrace2(base : NativeUInt; buffer : PPointer; size : Integer) : Integer;
var SPMin : NativeUInt;
begin
SPMin:=base;
Result:=0;
while (size > 0) and (base >= SPMin) and (base <> 0) do begin
buffer^:=PPointer(base + 4)^;
base:=PNativeInt(base)^;
//uncomment to test stacktrace
//WriteLn(inttohex(NativeUInt(buffer^), 8));
Inc(Result);
Inc(buffer);
Dec(size);
end;
if (size > 0) then buffer^:=nil;
end;
procedure UnInstallExceptionHandler; forward;
var
InRaiseException: Boolean;
function RaiseException(Exc: Pointer): LongBool; cdecl;
var b : NativeUInt;
c : Integer;
buff : array[0..7] of Pointer;
begin
InRaiseException := True;
asm
mov b, ebp
end;
c:=backtrace2(b - $4 {this is the compiler dependent value}, #buff, Length(buff));
//... do whatever you want to do with the stacktrace
Result := PrevRaiseException(Exc);
InRaiseException := False;
end;
procedure InstallExceptionHandler;
var
U: TUnwinder;
begin
GetUnwinder(U);
Assert(Assigned(U.RaiseException));
PrevRaiseException := U.RaiseException;
U.RaiseException := RaiseException;
SetUnwinder(U);
end;
procedure UnInstallExceptionHandler;
var
U: TUnwinder;
begin
GetUnwinder(U);
U.RaiseException := PrevRaiseException;
SetUnwinder(U);
end;
initialization
InstallExceptionHandler;
end.
You can use GetExceptionStackInfoProc, CleanUpStackInfoProc and GetStackInfoStringProc in Exception class you need to save stack trace in GetExceptionStackInfoProc and then retrieve it with GetStackInfoStringProc which will get called by RTL if you use StackTrace property of the Exception. Maybe you could also take look at https://bitbucket.org/shadow_cs/delphi-arm-backtrace which demonstrates this on Android.
To do this properly on Mac OS X the libc backtrace function cannot be used because Delphi will corrupt stack frame when calling the GetExceptionStackInfoProc from Exception.RaisingException. Own implementation must be used that is capable of walking the stack from different base address which can be corrected by hand.
Your GetExceptionStackInfoProc would then look like this (I used XE5 for this example the value added to EBP bellow may differ based on which compiler you use and this example was only tested on Mac OS X, Windows implementation may or may not differ):
var b : NativeUInt;
c : Integer;
buff : array[0..7] of Pointer;
begin
asm
mov b, ebp
end;
c:=backtrace2(b - $14 {this is the compiler dependent value}, #buff, Length(buff));
//... do whatever you want to do with the stacktrace
end;
And the backtrace2 function would look like this (note that stop conditions and other validations are missing in the implementation to ensure that AVs are not caused during stack walking):
function backtrace2(base : NativeUInt; buffer : PPointer; size : Integer) : Integer;
var SPMin : NativeUInt;
begin
SPMin:=base;
Result:=0;
while (size > 0) and (base >= SPMin) and (base <> 0) do begin
buffer^:=PPointer(base + 4)^;
base:=PNativeInt(base)^;
Inc(Result);
Inc(buffer);
Dec(size);
end;
if (size > 0) then buffer^:=nil;
end;
You could hook yourself into the Exception Unwinder. Then you can call backtrace where the exception happens. Here's an example. The unit SBMapFiles is what I use for reading the mapfiles. It is not required to get the exception call stack.
unit MyExceptionHandler;
interface
implementation
uses
Posix.Base, SysUtils, SBMapFiles;
function backtrace(result: PNativeUInt; size: Integer): Integer; cdecl; external libc name '_backtrace';
function _NSGetExecutablePath(buf: PAnsiChar; BufSize: PCardinal): Integer; cdecl; external libc name '__NSGetExecutablePath';
var
PrevRaiseException: function(Exc: Pointer): LongBool; cdecl;
MapFile: TSBMapFile;
const
MaxDepth = 20;
SkipFrames = 3;
procedure ShowCurrentStack;
var
StackLog: PNativeUInt; //array[0..10] of Pointer;
Cnt: Integer;
I: Integer;
begin
{$POINTERMATH ON}
GetMem(StackLog, SizeOf(Pointer) * MaxDepth);
try
Cnt := backtrace(StackLog, MaxDepth);
for I := SkipFrames to Cnt - 1 do
begin
if StackLog[I] = $BE00EF00 then
begin
WriteLn('---');
Break;
end;
WriteLn(IntToHex(StackLog[I], 8), ' ', MapFile.GetFunctionName(StackLog[I]));
end;
finally
FreeMem(StackLog);
end;
{$POINTERMATH OFF}
end;
procedure InstallExceptionHandler; forward;
procedure UnInstallExceptionHandler; forward;
var
InRaiseException: Boolean;
function RaiseException(Exc: Pointer): LongBool; cdecl;
begin
InRaiseException := True;
ShowCurrentStack;
Result := PrevRaiseException(Exc);
InRaiseException := False;
end;
procedure InstallExceptionHandler;
var
U: TUnwinder;
begin
GetUnwinder(U);
Assert(Assigned(U.RaiseException));
PrevRaiseException := U.RaiseException;
U.RaiseException := RaiseException;
SetUnwinder(U);
end;
procedure UnInstallExceptionHandler;
var
U: TUnwinder;
begin
GetUnwinder(U);
U.RaiseException := PrevRaiseException;
SetUnwinder(U);
end;
procedure LoadMapFile;
var
FileName: array[0..255] of AnsiChar;
Len: Integer;
begin
if MapFile = nil then
begin
MapFile := TSBMapFile.Create;
Len := Length(FileName);
_NSGetExecutablePath(#FileName[0], #Len);
if FileExists(ChangeFileExt(FileName, '.map')) then
MapFile.LoadFromFile(ChangeFileExt(FileName, '.map'));
end;
end;
initialization
LoadMapFile;
InstallExceptionHandler;
end.
I need to determine which folders contain files that have been modified "recently" (within a certain interval). I notice that folder datestamps seem to get updated whenever a contained file is modified, but this behaviour doesn't propagate up the tree, i.e. the datestamp of the folder containing the folder that contains the modified file doesn't get updated.
I can work with this behaviour, but I suspect it depends on platform/file system/network or local drive, etc. I would still like to take advantage of it where I could, so I need a boolean function to return true if the platform/disk running my app supports this behaviour.
I'm quite happy to recurse through the tree. What I want to avoid is having to do a FindFirst/FindNext for every file in every folder to see if any have been modified in (say) the last day - if I can avoid doing that for folders that don't have their datestamps modified within the last day it will save a great deal of time.
Check the FindFirstChangeNotification and FindNextChangeNotification functions
another option is use the TJvChangeNotify JEDI component.
addionally you can check this link
Obtaining Directory Change Notifications
The solutions that have been posted so far are about obtaining notifications as they happen, and they'll work well for that purpose. If you want to look into the past and see when something was last changed, as opposed to monitoring it in real time, then it gets tricker. I think there's no way to do that except by recursively searching through the folder tree and checking datestamps.
EDIT: In response to the OP's comment, yeah, it doesn't look like there's any way to configure FindFirst/FindNext to only hit directories and not files. But you can skip checking the dates on the files with this filter: (SearchRec.Attr and SysUtils.faDirectory <> 0). That should speed things up a little. Don't check the dates on the files at all. You'll probably still have to scan through everything, though, since the Windows API doesn't provide any way (that I know of) to only query for folders and not files.
I wrote a code for this purpose for one of my projects. This uses FindFirstChangeNotification and FindNextChangeNotification API functions.
Here is the code (I removed some project specific portions):
/// <author> Ali Keshavarz </author>
/// <date> 2010/07/23 </date>
unit uFolderWatcherThread;
interface
uses
SysUtils, Windows, Classes, Generics.Collections;
type
TOnThreadFolderChange = procedure(Sender: TObject; PrevModificationTime, CurrModificationTime: TDateTime) of object;
TOnThreadError = procedure(Sender: TObject; const Msg: string; IsFatal: Boolean) of object;
TFolderWatcherThread = class(TThread)
private
class var TerminationEvent : THandle;
private
FPath : string;
FPrevModificationTime : TDateTime;
FLatestModification : TDateTime;
FOnFolderChange : TOnThreadFolderChange;
FOnError : TOnThreadError;
procedure DoOnFolderChange;
procedure DoOnError(const ErrorMsg: string; IsFatal: Boolean);
procedure HandleException(E: Exception);
protected
procedure Execute; override;
public
constructor Create(const FolderPath: string;
OnFolderChangeHandler: TOnThreadFolderChange;
OnErrorHandler: TOnThreadError);
destructor Destroy; override;
class procedure PulseTerminationEvent;
property Path: string read FPath;
property OnFolderChange: TOnThreadFolderChange read FOnFolderChange write FOnFolderChange;
property OnError: TOnThreadError read FOnError write FOnError;
end;
/// <summary>
/// Provides a list container for TFolderWatcherThread instances.
/// TFolderWatcherThreadList can own the objects, and terminate removed items
/// automatically. It also uses TFolderWatcherThread.TerminationEvent to unblock
/// waiting items if the thread is terminated but blocked by waiting on the
/// folder changes.
/// </summary>
TFolderWatcherThreadList = class(TObjectList<TFolderWatcherThread>)
protected
procedure Notify(const Value: TFolderWatcherThread; Action: TCollectionNotification); override;
end;
implementation
{ TFolderWatcherThread }
constructor TFolderWatcherThread.Create(const FolderPath: string;
OnFolderChangeHandler: TOnThreadFolderChange; OnErrorHandler: TOnThreadError);
begin
inherited Create(True);
FPath := FolderPath;
FOnFolderChange := OnFolderChangeHandler;
Start;
end;
destructor TFolderWatcherThread.Destroy;
begin
inherited;
end;
procedure TFolderWatcherThread.DoOnFolderChange;
begin
Queue(procedure
begin
if Assigned(FOnFolderChange) then
FOnFolderChange(Self, FPrevModificationTime, FLatestModification);
end);
end;
procedure TFolderWatcherThread.DoOnError(const ErrorMsg: string; IsFatal: Boolean);
begin
Synchronize(procedure
begin
if Assigned(Self.FOnError) then
FOnError(Self,ErrorMsg,IsFatal);
end);
end;
procedure TFolderWatcherThread.Execute;
var
NotifierFielter : Cardinal;
WaitResult : Cardinal;
WaitHandles : array[0..1] of THandle;
begin
try
NotifierFielter := FILE_NOTIFY_CHANGE_DIR_NAME +
FILE_NOTIFY_CHANGE_LAST_WRITE +
FILE_NOTIFY_CHANGE_FILE_NAME +
FILE_NOTIFY_CHANGE_ATTRIBUTES +
FILE_NOTIFY_CHANGE_SIZE;
WaitHandles[0] := FindFirstChangeNotification(PChar(FPath),True,NotifierFielter);
if WaitHandles[0] = INVALID_HANDLE_VALUE then
RaiseLastOSError;
try
WaitHandles[1] := TerminationEvent;
while not Terminated do
begin
//If owner list has created an event, then wait for both handles;
//otherwise, just wait for change notification handle.
if WaitHandles[1] > 0 then
//Wait for change notification in the folder, and event signaled by
//TWatcherThreads (owner list).
WaitResult := WaitForMultipleObjects(2,#WaitHandles,False,INFINITE)
else
//Wait just for change notification in the folder
WaitResult := WaitForSingleObject(WaitHandles[0],INFINITE);
case WaitResult of
//If a change in the monitored folder occured
WAIT_OBJECT_0 :
begin
// notifiy caller.
FLatestModification := Now;
DoOnFolderChange;
FPrevModificationTime := FLatestModification;
end;
//If event handle is signaled, let the loop to iterate, and check
//Terminated status.
WAIT_OBJECT_0 + 1: Continue;
end;
//Continue folder change notification job
if not FindNextChangeNotification(WaitHandles[0]) then
RaiseLastOSError;
end;
finally
FindCloseChangeNotification(WaitHandles[0]);
end;
except
on E: Exception do
HandleException(E);
end;
end;
procedure TFolderWatcherThread.HandleException(E: Exception);
begin
if E is EExternal then
begin
DoOnError(E.Message,True);
Terminate;
end
else
DoOnError(E.Message,False);
end;
class procedure TFolderWatcherThread.PulseTerminationEvent;
begin
/// All instances of TFolderChangeTracker which are waiting will be unblocked,
/// and blocked again immediately to check their Terminated property.
/// If an instance is terminated, then it will end its execution, and the rest
/// continue their work.
PulseEvent(TerminationEvent);
end;
{ TFolderWatcherThreadList }
procedure TFolderWatcherThreadList.Notify(const Value: TFolderWatcherThread;
Action: TCollectionNotification);
begin
if OwnsObjects and (Action = cnRemoved) then
begin
/// If the thread is running, terminate it, before freeing it.
Value.Terminate;
/// Pulse global termination event to all TFolderWatcherThread instances.
TFolderWatcherThread.PulseTerminationEvent;
Value.WaitFor;
end;
inherited;
end;
end.
This provides two classes; a thread class which monitors a folder for changes, and if a change is detected, it will return the current change time and the previous change time through OnFolderChange event. And a list class for storing a list of monitoring threads. This list terminates each own thread automatically when the thread is removed from list.
I hope it helps you.
you should have a look at http://help.delphi-jedi.org/item.php?Id=172977 which is a ready solution.
If you do not want to download & install whole JVCL (which is however a great piece of code ;) ) you might want to see the file source online - http://jvcl.svn.sourceforge.net/viewvc/jvcl/trunk/jvcl/run/JvChangeNotify.pas?revision=12481&view=markup