I am working on a browser helper object written in Delphi, and when the BHO is installed and I close IE, I get the error "runtime error 216 at < address >". I suspect this could be because of the 253 disID (onquit) case on the following code:
function TIEM.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer;
Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult;
type
POleVariant=^OleVariant;
var
dps:TDispParams absolute Params;
bHasParams:Boolean;
pDispIDs:PDispIDList;
iDispIDsSize:Integer;
begin
Result:=DISP_E_MEMBERNOTFOUND;
pDispIDs:=nil;
iDispIDsSize:=0;
bHasParams:=(dps.cArgs>0);
if(bHasParams)then
begin
iDispIDsSize:=dps.cArgs*SizeOf(TDispID);
GetMem(pDispIDs,iDispIDsSize);
end;
try
if(bHasParams)then BuildPositionalDispIDs(pDispIDs,dps);
case DispID of
104:begin
Result:=S_OK;
end;
250:begin
DoBeforeNavigate2(IDispatch(dps.rgvarg^[pDispIDs^[0]].dispVal),
POleVariant(dps.rgvarg^[pDispIDs^[1]].pvarVal)^,
POleVariant(dps.rgvarg^[pDispIDs^[2]].pvarVal)^,
POleVariant(dps.rgvarg^[pDispIDs^[3]].pvarVal)^,
POleVariant(dps.rgvarg^[pDispIDs^[4]].pvarVal)^,
POleVariant(dps.rgvarg^[pDispIDs^[5]].pvarVal)^,
dps.rgvarg^[pDispIDs^[6]].pbool^);
Result:=S_OK;
end;
252:
begin
DoNavigateComplete2(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval), POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^);
Result := S_OK;
end;
259:
begin
DoDocumentComplete(IDispatch(dps.rgvarg^[pDispIds^[0]].dispval), POleVariant(dps.rgvarg^[pDispIds^[1]].pvarval)^);
Result := S_OK;
end;
253:
begin
Result := S_OK;
end;
else
Result := DISP_E_MEMBERNOTFOUND;
end;
finally
if(bHasParams)then
FreeMem(pDispIDs,iDispIDsSize);
end;
end;
But I am not sure and I couldn't find any info about it. I am using a library I got from an example on Hack China to create the BHO, and I found some project on Google Code that uses IConnectionPoint.Unadvise(Integer) on the 253 case. I tried that, but still get the same runtime error 216. I've also tried adding an exception handler to the above code, but it didn't catch anything.
I added:
finalization
exit;
And now I don't see the runtime error. I didn't know the BHO would need that.
A 216 error when exiting your app means your are triggering an Access Violation in the finalization code of your project after the sysutils unit has already been finalized.
So, check all your finalization sections for use of invalid pointers. In your search include the finalization sections of all components you use in the project.
To debug finalization sections, you can put a breakpoint on the "end" statement in the dpr and when the debugger breaks on that, use F7 to step into the finalization code, then use F7 and F8 to step through all the finalization sections. It will be a tedious process, but it will bring you to the exact statement causing the Access Violation.
I added:
finalization
exit;
And now I don't see the runtime error. I didn't know the BHO would need that.
Related
Somewhere in my application (along with 3rd party libraries of code) is a window procedure that is preventing Windows from:
logging off
shutting down
restarting
I found one spot in my code where I made the extraordinarily common mistake of calling DefWindowProc, but calling it incorrectly:
Before:
void Grobber.BroadcastListenerWindowProc(ref TMessage msg)
{
DefWindowProc(_broadcastListenerHwnd, msg.msg, msg.wparam, msg.lparam);
}
After:
void Grobber.BroadcastListenerWindowProc(ref TMessage msg)
{
//20170207: Forgetting to set the result can, for example, prevent Windows from restarting
msg.Result = DefWindowProc(_broadcastListenerHwnd, msg.msg, msg.wparam, msg.lparam);
}
I fixed that bug, and my test program no longer halted the shutdown.
But a full application does
I'm now faced with having to tear a program down to nothing, until my computer finally reboots.
Somewhere deep inside my application is a Window procedure attached to an HWND that is returning zero to WM_QUERYENDSESSION. If only i knew the HWND, i could use the Spy++ to find the Window.
But how can i find that hwnd?
The Windows Application event log notes the process that halt a shutdown:
And there very well be a more detailed log in the more detailed Applications and Services Logs. But those are undocumented.
How can i find my problematic hwnd?
Attempts
I tried to use EnumThreadWindows to get all the windows of my "main" thread, with the idea of manually sending WM_QUERYENDSESSION to them all to see who returns false:
var
wnds: TList<HWND>;
function DoFindWindow(Window: HWnd; Param: LPARAM): Bool; stdcall;
var
wnds: TList<HWND>;
begin
wnds := TList<HWND>(Param);
wnds.Add(Window);
Result := True;
end;
wnds := TList<HWND>.Create;
enumProc := #DoFindWindow;
EnumThreadWindows(GetCurrentThreadId, EnumProc, LPARAM(wnds));
Now i have a list of twelve hwnds. Poke them:
var
window: HWND;
res: LRESULT;
for window in wnds do
begin
res := SendMessage(window, WM_QUERYENDSESSION, 0, 0);
if res = 0 then
begin
ShowMessage('Window: '+IntToHex(window, 8)+' returned false to WM_QUERYENDSESSION');
end;
end;
But nobody did return zero.
So that's one tube down the drain.
EnumThreadWindows only enumerates the windows of one particular thread. It could be that the offending window was created in a thread. So I'd suggest that you use EnumWindows to enum all top level windows in your application for your test.
It's enough to initialize COM in a thread and you'll have a window you don't know about. That way a call to WaitForSingleObject in a thread could be your culprit:
Debugging an application that would not behave with WM_QUERYENDSESSION
This might sound a bit like overkill but here goes. I would solve this using code hooks for AllocateHWnd and DeallocateHWnd. We had to solve a different issue related to handles and it worked well for us.
Your replacement routines will just be copies of the versions in System.Classes. You will also need to copy all of the dependencies (PObjectInstance, TObjectInstance, CodeBytes, PInstanceBlock, TInstanceBlock, InstBlockList, InstFreeList, StdWndProc, CalcJmpOffset, MakeObjectInstance, FreeObjectInstance, CleanupInstFreeList, GetFreeInstBlockItemCount, ReleaseObjectInstanceBlocks, UtilWindowClass) from that unit. The only difference is that you log all allocated and deallocated handles in your replacement routines. It would help to include stack traces too.
That will give you a list of all of the handles that are allocated at the time of your shutdown along with their calling stack traces.
The basic structure is something like this. I can't post full code because it's mostly VCL code with the exception of the code hooks and logging.
const
{$IF Defined(CPUX86)}
CodeBytes = 2;
{$ELSEIF Defined(CPUX64)}
CodeBytes = 8;
{$ENDIF CPU}
InstanceCount = (4096 - SizeOf(Pointer) * 2 - CodeBytes) div SizeOf(TObjectInstance) - 1;
type
PInstanceBlock = ^TInstanceBlock;
TInstanceBlock = packed record
...
end;
var
InstBlockList: PInstanceBlock;
InstFreeList: PObjectInstance;
{ Standard window procedure }
function StdWndProc(Window: HWND; Message: UINT; WParam: WPARAM; LParam: WPARAM): LRESULT; stdcall;
...
function CalcJmpOffset(Src, Dest: Pointer): Longint;
...
function MakeObjectInstance(const AMethod: TWndMethod): Pointer;
...
procedure FreeObjectInstance(ObjectInstance: Pointer);
...
procedure CleanupInstFreeList(BlockStart, BlockEnd: PByte);
...
function GetFreeInstBlockItemCount(Item: PObjectInstance; Block: PInstanceBlock): Integer;
...
procedure ReleaseObjectInstanceBlocks;
...
var
UtilWindowClass: TWndClass = (
... );
function AllocateHWnd(const AMethod: TWndMethod): HWND;
begin
< Logging/Stack trace code here >
...
end;
procedure DeallocateHWnd(Wnd: HWND);
begin
< Logging/Stack trace code here >
...
end;
It may also be necessary to hook and log SetWindowLong, SetWindowLongA and SetWindowLongW too.
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 have a room with 60 computers/devices (40 computers and 20 oscilloscopes Windows CE based) and I would like to know which and every one is alive using ping. First I wrote a standard ping (see here Delphi Indy Ping Error 10040), which is working fine now but takes ages when most computers are offline.
So what I am trying to do is to write a MultiThread Ping but I am quite struggling with it. I have seen only very few examples over the internet and no one was matching my needs, that's why I try to write it myself.
I use XE2 and Indy 10 and the form is only constitued of a memo and a button.
unit Main;
interface
uses
Winapi.Windows, System.SysUtils, System.Classes, Vcl.Forms,
IdIcmpClient, IdGlobal, Vcl.StdCtrls, Vcl.Controls;
type
TMainForm = class(TForm)
Memo1: TMemo;
ButtonStartPing: TButton;
procedure ButtonStartPingClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TMyPingThread = class(TThread)
private
fIndex : integer;
fIdIcmpClient: TIdIcmpClient;
procedure doOnPingReply;
protected
procedure Execute; override;
public
constructor Create(index: integer);
end;
var
MainForm: TMainForm;
ThreadCOunt : integer;
implementation
{$R *.dfm}
constructor TMyPingThread.Create(index: integer);
begin
inherited Create(false);
fIndex := index;
fIdIcmpClient := TIdIcmpClient.Create(nil);
fIdIcmpClient.ReceiveTimeout := 200;
fIdIcmpClient.PacketSize := 24;
fIdIcmpClient.Protocol := 1;
fIdIcmpClient.IPVersion := Id_IPv4;
//first computer is at adresse 211
fIdIcmpClient.Host := '128.178.26.'+inttostr(211+index-1);
self.FreeOnTerminate := true;
end;
procedure TMyPingThread.doOnPingReply;
begin
MainForm.Memo1.lines.add(inttostr(findex)+' '+fIdIcmpClient.ReplyStatus.Msg);
dec(ThreadCount);
if ThreadCount = 0 then
MainForm.Memo1.lines.add('--- End ---');
end;
procedure TMyPingThread.Execute;
begin
inherited;
try
fIdIcmpClient.Ping('',findex);
except
end;
while not Terminated do
begin
if fIdIcmpClient.ReplyStatus.SequenceId = findex then Terminate;
end;
Synchronize(doOnPingReply);
fIdIcmpClient.Free;
end;
procedure TMainForm.ButtonStartPingClick(Sender: TObject);
var
i: integer;
myPing : TMyPingThread;
begin
Memo1.Lines.Clear;
ThreadCount := 0;
for i := 1 to 40 do
begin
inc(ThreadCount);
myPing := TMyPingThread.Create(i);
//sleep(10);
end;
end;
end.
My problem is that it "seems" to work when I uncomment the "sleep(10)", and "seems" not to be working without it. This for sure means I am missing a point in the threading I have written.
In other words. When Sleep(10) is in the code. Every time I clicked the button to get to check the connections the result was correct.
Without the sleep(10), it is working "most" of the time but some times the result is wrong giving me a ping echo on offline computers and no ping echo on online computer, as is the ping reply was not assigned to the correct thread.
Any comment or help is welcome.
----- EDIT / IMPORTANT -----
As a general follow up of this question, #Darian Miller started a Google Code project here https://code.google.com/p/delphi-stackoverflow/ which is a working basis. I mark his answer as the "accepted answer" but users should refer to this open source project (all the credit belongs to him) as it will surely be extended and updated in the future.
The root problem is that pings are connectionless traffic. If you have multiple TIdIcmpClient objects pinging the network at the same time, one TIdIcmpClient instance can receive a reply that actually belongs to another TIdIcmpClient instance. You are trying to account for that in your thread loop, by checking SequenceId values, but you are not taking into account that TIdIcmpClient already does that same check internally. It reads network replies in a loop until it receives the reply it is expecting, or until the ReceiveTimeout occurs. If it receives a reply it is not expecting, it simply discards that reply. So, if one TIdIcmpClient instance discards a reply that another TIdIcmpClient instance was expecting, that reply will not get processed by your code, and that other TIdIcmpClient will likely receive another TIdIcmpClient's reply instead, and so on. By adding the Sleep(), you are decreasing (but not eliminating) the chances that pings will overlap each other.
For what you are attempting to do, you won't be able to use TIdIcmpClient as-is to have multiple pings running in parallel, sorry. It is simply not designed for that. There is no way for it to differentiate reply data the way you need it. You will have to serialize your threads so only one thread can call TIdIcmpClient.Ping() at a time.
If serializing the pings is not an option for you, you can try copying portions of TIdIcmpClient's source code into your own code. Have 41 threads running - 40 device threads and 1 response thread. Create a single socket that all of the threads share. Have each device thread prepare and send its individual ping request to the network using that socket. Then have the response thread continuously reading replies from that same socket and routing them back to the appropriate device thread for processing. This is a bit more work, but it will give you the multiple-ping parallelism you are looking for.
If you don't want to go to all that trouble, an alternative is to just use a third-party app that already supports pinging multiple machines at the same time, like FREEPing.
Remy explained the problems... I've wanted to do this in Indy for a while so I posted a possible solution that I just put together to a new Google Code project instead of having a long comment here. It's a first-stab sort of thing, let me know if you have some changes to integrate:
https://code.google.com/p/delphi-vault/
This code has two ways to Ping...multi-threaded clients as in your example, or with a simple callback procedure. Written for Indy10 and later versions of Delphi.
Your code would end up using a TThreadedPing descendant defining a SynchronizedResponse method:
TMyPingThread = class(TThreadedPing)
protected
procedure SynchronizedResponse(const ReplyStatus:TReplyStatus); override;
end;
And to fire off some client threads, the code becomes something like:
procedure TfrmThreadedPingSample.butStartPingClick(Sender: TObject);
begin
TMyPingThread.Create('www.google.com');
TMyPingThread.Create('127.0.0.1');
TMyPingThread.Create('www.shouldnotresolvetoanythingatall.com');
TMyPingThread.Create('127.0.0.1');
TMyPingThread.Create('www.microsoft.com');
TMyPingThread.Create('127.0.0.1');
end;
The threaded response is called in a synchronized method:
procedure TMyPingThread.SynchronizedResponse(const ReplyStatus:TReplyStatus);
begin
frmThreadedPingSample.Memo1.Lines.Add(TPingClient.FormatStandardResponse(ReplyStatus));
end;
I did not try your code, so that is all hypothetical, but i think you messed the threads and got classic race condition. I restate my advice to use AsyncCalls or OmniThreadLibrary - they are much simpler and would save you few attempts at "shooting your own foot".
Threads are made to minimize main-thread load. Thread constructor should do minimal work of remembering parameters. Personally i'd moved idICMP creation into .Execute method. If for any reason it would want to create its internal synchronization objects, like window and message queue or signal or whatever, i'd like it to happen already in a new spawned thread.
There is no sense for "inherited;" in .Execute. Better remove it.
Silencing all exceptions is bad style. You probably have errors - but have no way to know about them. You should propagate them to main thread and display them. OTL and AC help you in that, while for tThread you have to do it manually. How to Handle Exceptions thrown in AsyncCalls function without calling .Sync?
Exception logic is flawed. There is no point to have a loop if exception thrown - if no succesful Ping was set - then why waiting for response ? You loop should go within same try-except frame as issuing ping.
Your doOnPingReply executes AFTER fIdIcmpClient.Free yet accesses fIdIcmpClient's internals. Tried changing .Free for FreeAndNil ?
That is a classic mistake of using dead pointer after freeing it.
The correct approach would be to:
5.1. either free the object in doOnPingReply
5.2. or copy all relevant data from doOnPingReply to TThread's private member vars before calling both Synchronize and idICMP.Free (and only use those vars in doOnPingReply )
5.3. only do fIdIcmpClient.Free inside TMyThread.BeforeDestruction or TMyThread.Destroy. Afterall, if you chosen to create the object in constructor - then you should free it in the matching language construct - destructor.
Since you do not keep references to the thread objects - that While not Terminated loop seems redundant. Just make usual forever-loop and call break.
The aforementioned loop is CPU-hungry, it is like spin-loop. Please call Sleep(0); or Yield(); inside loop to give other threads better chance to do their work. Don't work agaisnt OS scheduler here - you are not in a speed-critical path, no reason to make spinlock here.
Overall, i consider:
4 and 5 as critical bugs for you
1 and 3 as a potential gotcha maybe influencing or maybe not. You'd better 'play safe' rather than doing risky things and investigating if they would work or not.
2 and 7 - bad style, 2 regarding language and 7 regarding platform
6 either you have plans to extend your app, or you broke YAGNI principle, dunno.
Sticking with complex TThread instead of OTL or AsyncCalls - strategic errors. Don't you put rooks on your runway, use simple tools.
Funny, this is example of the bug that FreeAndNil could expose and make obvious, while FreeAndNil-haters are claiming it "conceals" bugs.
// This is my communication unit witch works well, no need to know its work but your
// ask is in the TPingThread class.
UNIT UComm;
INTERFACE
USES
Windows, Messages, SysUtils, Classes, Graphics, Controls, ExtCtrls, Forms, Dialogs,
StdCtrls,IdIcmpClient, ComCtrls, DB, abcwav, SyncObjs, IdStack, IdException,
IdTCPServer, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdContext,
UDM, UCommon;
TYPE
TNetworkState = (nsNone, nsLAN, nsNoLAN, nsNet, nsNoNet);
TDialerStatus = (dsNone, dsConnected, dsDisconnected, dsNotSync);
{ TBaseThread }
TBaseThread = Class(TThread)
Private
FEvent : THandle;
FEventOwned : Boolean;
Procedure ThreadTerminate(Sender: TObject); Virtual;
Public
Constructor Create(AEventName: String);
Property EventOwned: Boolean Read FEventOwned;
End;
.
.
.
{ TPingThread }
TPingThread = Class(TBaseThread)
Private
FReply : Boolean;
FTimeOut : Integer;
FcmpClient : TIdIcmpClient;
Procedure ReplyEvent(Sender: TComponent; Const AReplyStatus: TReplyStatus);
Protected
Procedure Execute; Override;
Procedure ThreadTerminate(Sender: TObject); Override;
Public
Constructor Create(AHostIP, AEventName: String; ATimeOut: Integer);
Property Reply: Boolean Read FReply;
End;
.
.
.
{ =============================================================================== }
IMPLEMENTATION
{$R *.dfm}
USES
TypInfo, WinSock, IdGlobal, UCounter, UGlobalInstance, URemoteDesktop;
{IdGlobal: For RawToBytes function 10/07/2013 04:18 }
{ TBaseThread }
//---------------------------------------------------------
Constructor TBaseThread.Create(AEventName: String);
Begin
SetLastError(NO_ERROR);
FEvent := CreateEvent(Nil, False, False, PChar(AEventName));
If GetLastError = ERROR_ALREADY_EXISTS
Then Begin
CloseHandle(FEvent);
FEventOwned := False;
End
Else If FEvent <> 0 Then
Begin
FEventOwned := True;
Inherited Create(True);
FreeOnTerminate := True;
OnTerminate := ThreadTerminate;
End;
End;
//---------------------------------------------------------
Procedure TBaseThread.ThreadTerminate(Sender: TObject);
Begin
CloseHandle(FEvent);
End;
{ TLANThread }
.
.
.
{ TPingThread }
//---------------------------------------------------------
Constructor TPingThread.Create(AHostIP: String; AEventName: String; ATimeOut: Integer);
Begin
Inherited Create(AEventName);
If Not EventOwned Then Exit;
FTimeOut := ATimeOut;
FcmpClient := TIdIcmpClient.Create(Nil);
With FcmpClient Do
Begin
Host := AHostIP;
ReceiveTimeOut := ATimeOut;
OnReply := ReplyEvent;
End;
End;
//---------------------------------------------------------
Procedure TPingThread.Execute;
Begin
Try
FcmpClient.Ping;
FReply := FReply And (WaitForSingleObject(FEvent, FTimeOut) = WAIT_OBJECT_0);
Except
FReply := False;
End;
End;
//---------------------------------------------------------
Procedure TPingThread.ReplyEvent(Sender: TComponent; Const AReplyStatus: TReplyStatus);
Begin
With AReplyStatus Do
FReply := (ReplyStatusType = rsEcho) And (BytesReceived <> 0);
SetEvent(FEvent);
End;
//---------------------------------------------------------
Procedure TPingThread.ThreadTerminate(Sender: TObject);
Begin
FreeAndNil(FcmpClient);
Inherited;
End;
{ TNetThread }
.
.
.
I Delphi, I need a function which determinates if the system menu (resp. window menu, the menu that appears when the icon is clicked) is opened. The reason is that I am writing a anti-keylogger functionality which sends garbage to the current active editcontrol (this also prevents keylogger which read WinAPI messages to read the content). But if system-menu is opened, the editcontrol STILL has the focus, so the garbage will invoke shortcuts.
If I use message WM_INITMENUPOPUP in my TForm1, I can determinate when the system menu opens, but I wish that I do not have to change the TForm, since I want to write a non visual component, which does not need any modifications at the TForm-derivate-class itself.
//I do not want that solution since I have to modify TForm1 for that!
procedure TForm1.WMInitMenuPopup(var Message: TWMInitMenuPopup);
begin
if message.MenuPopup=getsystemmenu(Handle, False) then
begin
SystemMenuIsOpened := true;
end;
end;
TApplicaton.HookMainWindow() does not send the WM_INITMENUPOPUP to my hook function.
function TForm1.MessageHook(var Msg: TMessage): Boolean;
begin
Result := False;
if (Msg.Msg = WM_INITMENUPOPUP) then
begin
// Msg.Msg IS NEVER WM_INITMENUPOPUP!
if LongBool(msg.LParamHi) then
begin
SystemMenuIsOpened := true;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Application.HookMainWindow(MessageHook);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Application.UnhookMainWindow(MessageHook);
end;
Even after very long research I did not found any information about how to query if the system-menu is opened or not. I do not find any way to determinate the opening+closing of that menu.
Has someone a solution for me please?
Regards
Daniel Marschall
Application.HookMainWindow doesn't do what you seem to think. It hooks the hidden application window, not the main form. To intercept WM_INITMENUPOPUP on a specific form, all you need to do is write a handler for it, as you have seen.
To do this generically for any owner form of a component, you could assign WindowProc property of the form to place the hook:
unit FormHook;
interface
uses
Windows, Classes, SysUtils, Messages, Controls, Forms;
type
TFormMessageEvent = procedure(var Message: TMessage; var Handled: Boolean) of object;
TFormHook = class(TComponent)
private
FForm: TCustomForm;
FFormWindowProc: TWndMethod;
FOnFormMessage: TFormMessageEvent;
protected
procedure FormWindowProc(var Message: TMessage); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property OnFormMessage: TFormMessageEvent read FOnFormMessage write FOnFormMessage;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Test', [TFormHook]);
end;
procedure TFormHook.FormWindowProc(var Message: TMessage);
var
Handled: Boolean;
begin
if Assigned(FFormWindowProc) then
begin
Handled := False;
if Assigned(FOnFormMessage) then
FOnFormMessage(Message, Handled);
if not Handled then
FFormWindowProc(Message);
end;
end;
constructor TFormHook.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FFormWindowProc := nil;
FForm := nil;
while Assigned(AOwner) do
begin
if AOwner is TCustomForm then
begin
FForm := TCustomForm(AOwner);
FFormWindowProc := FForm.WindowProc;
FForm.WindowProc := FormWindowProc;
Break;
end;
AOwner := AOwner.Owner;
end;
end;
destructor TFormHook.Destroy;
begin
if Assigned(FForm) and Assigned(FFormWindowProc) then
begin
FForm.WindowProc := FFormWindowProc;
FFormWindowProc := nil;
FForm := nil;
end;
inherited Destroy;
end;
end.
You could then use this component on a form:
procedure TForm1.FormHook1FormMessage(var Message: TMessage; var Handled: Boolean);
begin
case Message.Msg of
WM_INITMENUPOPUP:
...
end;
end;
The problem might be that if the form has any other components which do the same thing then you need to make sure that unhooking happens in reverse order (last hooked, first unhooked). The above example hooks in the constructor and unhooks in the destructor; this seems to work even with multiple instances on the same form.
If you don't want any modifications to TForm-derivate-class, why don't try pure Windows API way to implement your current solution, that is, use SetWindowLongPtr() to intercept the WM_INITMENUPOPUP message. Delphi VCL style to intercept messages is just a wrapper of this Windows API function actually.
For that purpose, use SetWindowLongPtr() to set a new address for the window procedure and to get the original address of the window procedure, both at one blow. Remember to store the original address in a LONG_PTR variable. In 32-bit Delphi, LONG_PTR was Longint; supposing 64-bit Delphi will have been released in the future, LONG_PTR should be Int64; you can use $IFDEF directive to distinguish them as follows:
Type
{$IFDEF WIN32}
PtrInt = Longint;
{$ELSE}
PtrInt = Int64;
{$ENDIF}
LONG_PTR = PtrInt;
The value for nIndex parameter to be used for this purpose is GWLP_WNDPROC. Also, pass the new address for the window procedure to dwNewLong parameter, e.g. LONG_PTR(NewWndProc). The NewWndProc is a WindowProc Callback Function that processes messages, it is where your put your intercept criteria and override the default handling of the message you are going to intercept. The callback function can be any name, but the parameters must follow the WindowProc convention.
Note that you must call CallWindowProc() to pass any messages not processed by the new window procedure to the original window procedure.
Finally, you should call SetWindowLongPtr() again somewhere in your code to set the address of modified/new window procedure handler back to the original address. The original address has been saved before as mentioned above.
There was a Delphi code example here. It used SetWindowLong(), but now Microsoft recommends to use SetWindowLongPtr() instead to make it compatible with both 32-bit and 64-bit versions of Windows.
SetWindowLongPtr() didn't exist in Windows.pas of Delphi prior to Delphi 2009. If you use an older version of Delphi, you must declare it by yourself, or use JwaWinUser unit of JEDI API Library.
Not tried this myself, but give this a shot:
Use GetMenuItemRect to get the rect for item 0 of the menu returned by GetSystemMenu.
I (assume!) GetMenuItemRect should return 0 if the system menu is not open (because system could not know the rect of the menu item unless it is open?) If the result is non-zero, check if the coords returned are possible for the given screen resolution.
If you have the time, you could look into AutoHotKey's source code to see how to monitor when system menu is open/closed.
I'm trying to compile this project in Delphi 2010, which uses TNetSharingManager. I have imported the type library and tried compiling it, but unfortunately I'm getting an Access Violation in this function:
function TNetSharingManager.GetDefaultInterface: INetSharingManager;
begin
if FIntf = nil then
Connect;
Assert(FIntf nil, 'DefaultInterface is NULL. Component is not connected to Server. You must call "Connect" or "ConnectTo" before this operation');
Result := FIntf;
end;
(part of NETCONLib_TLB)
The error is in : if FIntf = nil then for some odd reason..
The code which is calling it:
procedure TForm1.GetConnectionList(Strings,IdList: TStrings);
var
pEnum: IEnumVariant;
vNetCon: OleVARIANT;
dwRetrieved: Cardinal;
pUser: NETCONLib_TLB.PUserType1;
NetCon : INetConnection;
begin
Strings.Clear;
IdList.Clear;
pEnum := ( NetSharingManager.EnumEveryConnection._NewEnum as IEnumVariant);
while (pEnum.Next(1, vNetCon, dwRetrieved) = S_OK) do
begin
(IUnknown(vNetCon) as INetConnection).GetProperties(pUser);
NetCon := (IUnknown(vNetCon) as INetConnection);
if (pUser.Status in [NCS_CONNECTED,NCS_CONNECTING])//remove if you want disabled NIC cards also
and (pUser.MediaType in [NCM_LAN,NCM_SHAREDACCESSHOST_LAN,NCM_ISDN] )
and (GetMacAddress(GuidToString(pUser.guidId))'' ) then
begin
//we only want valid network cards that are enabled
Strings.Add(pUser.pszwName );
IdList.Add(GuidToString(pUser.guidId));
end;
end;
end;
I don't understand why I cannot compare with nil. Any ideas?
It is likely the TNetSharingManager object itself has actually died (or wasn't created in the first place) when that error is triggered. The FIntF = nil expression is the first reference to an actual field of the class, i.e. it will be pointing into invalid address space.
[Edit] I download the source and followed the steps to import the TLB (Delphi 2010). To execute the appilcation, I had to (a) run Delphi as an admin, because I'm not a power user by default and (b) had to add a check for pUser <> nil because the final getProperties returns a nil-structure, but other than that the code run fine. So unfortunately, I can't seem to reproduce your problem.
Rereading your question, are you getting an AV while compiling?