DLL Hook CBT
Il client di Scintilla necessita di conoscere quali finestre vengono create per potere intervenire nel momento stesso in cui la finestra viene creata, attivata ecc... Per potere essere informati di questo tipo di attività occorre creare un hook di sistema CBT. I messaggi che si ricevono sono del
tipo HCBT_CREATEWND, HCBT_ACTIVATE. Per una lista completa vedere qui. In realtà al nostro client non serve discernere quale messaggio sia stato ricevuto ma se anche solo un messaggio è stato ricevuto. Sulla base del lavoro di Primož Gabrijelčič ho creato un hook che si occupi solo di mandare il messaggio al componente sulla Form, senza alcun filtro. Il componente deve solo settare la dll che intende utilizzare e ha un solo evento che riceve i messaggi cbt.
il parametro importante è lparam perchè contiene l'handle della finestra. Con l'handle è possibile agire per ottenere ulteriori informazioni:
var
C: array[0..16384] of Char;
PID: UINT;
buf: Array [0..255] of char;
begin
SendMessage( W, WM_GETTEXT, 256, integer(@C));
GetWindowThreadProcessID(W,@PID);
GetClassName( W, Buf, 256);
Caption:=string(Buf);
Per quanto riguarda l'Hook di Mouse è sufficiente una copia perfetta di questo sorgente con riferimento ai messaggi WH_MOUSE. Quello che è molto importante quando si scrive un hook è di non portarsi dietro intere librerie di sistema solo per sfruttare una singola funzione. In questo caso le funzioni:
function StrScan(const Str: PChar; Chr: Char): PChar; assembler;
function LastDelimiter(const Delimiters, S: string): Integer;
function ExtractFileName(const FileName: string): string;
function ChangeFileExt(const FileName, Extension: string): string;
sono copiate dalla sysutils di Delphi ( possono variare da versione a versione ). Importarle ci evita tutta una serie di problemi legati all'exception handle durante il loading. Lo stesso concetto si applica per le procedure
procedure FreeTokenInformation(var Buffer: Pointer);
procedure QueryTokenInformation(Token: THandle; InformationClass: TTokenInformationClass; var Buffer: Pointer);
library HookCbtkDLL;
uses
Windows,
cbt in 'cbt.pas',
CbtCommon in 'CbtCommon.pas';
procedure DLLEntryPoint(reason: integer);
begin
if reason = DLL_PROCESS_DETACH then
Cbt.ProcessDetached;
end; { DLLEntryPoint }
exports
AttachReceiver,
DetachReceiver,
LastError;
begin
DisableThreadLibraryCalls(HInstance);
Cbt.ProcessAttached;
DLLProc := @DLLEntryPoint;
end.
unit Cbt;
interface
uses
Windows,
Messages,
CbtCommon ;
procedure ProcessAttached;
procedure ProcessDetached;
function AttachReceiver(receiver: THandle; Filter: boolean): integer; stdcall;
function DetachReceiver( receiver: THandle): integer; stdcall;
function LastError: DWORD; stdcall;
implementation
uses
CbtSecurity;
type
THookReceiver = record
Filtering: boolean;
Handle : THandle;
end;
TSharedHookData = record
HookCallback : HHOOK;
Receiver : THookReceiver;
end;
PSharedHookData = ^TSharedHookData;
TStaticHookData = record
HookCallback: TFNHookProc;
end;
type
THookWrapper = class
private
HookMutex: THandle;
fLastError: DWORD;
MemFile : THandle;
Receiver: THookReceiver; // il Tcomponent
Shared : PSharedHookData; // memory mapped file
Static : TStaticHookData;
protected
function Hook: integer; virtual;
function Unhook: integer; virtual;
public
constructor Create(baseName: string; hookCallback: TFNHookProc);
destructor Destroy; override;
function AttachReceiver(receiver: THandle; Filter: boolean): integer;
function DetachReceiver(receiver: THandle): integer;
procedure input(code: integer; wParam: WPARAM; lParam: LPARAM; var Result: LRESULT);
procedure CallNextHook(code: integer; wParam: WPARAM; lParam: LPARAM; var Result: LRESULT);
property LastError: DWORD read fLastError;
end;
var
Wrapper: THookWrapper;
function CBTHookCallback(code: integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
Result := 0;
if assigned(wrapper) and assigned(wrapper.Shared) then begin
WaitForSingleObject(wrapper.HookMutex, INFINITE);
try
if code = HCBT_ACTIVATE then
Wrapper.input(code,wParam,PCBTActivateStruct(lParam)^.hWndActive, Result)
else if code = HCBT_CLICKSKIPPED then
Wrapper.input(code,wParam,PMouseHookStruct(lParam)^.hwnd,Result)
else if code >=0 then
Wrapper.input(code,wParam,lParam,Result);
finally ReleaseMutex(wrapper.HookMutex); end;
Wrapper.CallNextHook(code,wParam,lParam,Result);
end;
end;
(*Copiate da SysUtils *)
function StrScan(const Str: PChar; Chr: Char): PChar; assembler;
asm
PUSH EDI
PUSH EAX
MOV EDI,Str
MOV ECX,0FFFFFFFFH
XOR AL,AL
REPNE SCASB
NOT ECX
POP EDI
MOV AX,Chr//GG
REPNE SCASB
MOV EAX,0
JNE @@1
MOV EAX,EDI
DEC EAX
@@1: POP EDI
end;
function LastDelimiter(const Delimiters, S: string): Integer;
var
P: PChar;
begin
Result := Length(S);
P := PChar(Delimiters);
while Result > 0 do begin
if (S[Result] <> #0) and (StrScan(P, S[Result]) <> nil) then
Exit;
Dec(Result);
end;
end;
function ExtractFileName(const FileName: string): string;
var
I: Integer;
begin
I := LastDelimiter('\:', FileName);
Result := Copy(FileName, I + 1, MaxInt);
end;
function ChangeFileExt(const FileName, Extension: string): string;
var
I: Integer;
begin
I := LastDelimiter('.\:',Filename);
if (I = 0) or (FileName[I] <> '.') then I := MaxInt;
Result := Copy(FileName, 1, I - 1) + Extension;
end;
(*fine copia SysUtils*)
procedure ProcessAttached;
var
hBaseName: array [0..MAX_PATH] of char;
strBaseName: string;
begin
if GetModuleFileName(HInstance, hBaseName, SizeOf(hBaseName)-1)= 0 then begin
MessageBox(0,'Hook','Failed to retrieve own module name!',MB_OK);
Halt;
end;
strBaseName := '_HOOK_'+ChangeFileExt(ExtractFileName(hBaseName),'')+'_';
Wrapper := THookWrapper.Create(strBaseName+'CBTALLMESSAGES', @CBTHookCallback);
end;
procedure ProcessDetached;
begin
wrapper.Free;
end;
function AttachReceiver(receiver: THandle; Filter: boolean): integer; stdcall;
begin
Result := Wrapper.AttachReceiver(receiver,Filter);
end;
function DetachReceiver( receiver: THandle): integer; stdcall;
begin
Result := Wrapper.DetachReceiver(receiver);
end;
function LastError: DWORD; stdcall;
begin
Result := Wrapper.LastError;
end;
function THookWrapper.AttachReceiver(receiver: THandle; Filter: boolean): integer;
begin
Result := 0;
if not assigned(Shared) then
Exit;
WaitForSingleObject(HookMutex, INFINITE);
try
if Shared^.Receiver.Handle <> 0 then Result := ERROR_TOO_MANY_RECEIVERS;
Shared^.Receiver.Handle := receiver;
Shared^.Receiver.Filtering := Filter;
if Shared^.Receiver.Handle <> 0 then // installo l'hook sul primo receiver
Result := Hook
else
Result := ERROR_NO_ERROR;
finally ReleaseMutex(HookMutex); end;
end;
procedure THookWrapper.input(code: integer; wParam: WPARAM; lParam: LPARAM; var Result: LRESULT);
var
msgRes : DWORD;
MsgSent : boolean;
begin
if Shared^.Receiver.Filtering then begin
MsgSent := SendMessageTimeout(Shared^.Receiver.Handle, WM_USER + code, wParam, lParam,
SMTO_ABORTIFHUNG OR SMTO_BLOCK, 5000{ms}, msgRes) <> 0;
if Result = 0 then
Result := msgRes;
end
else
MsgSent := PostMessage(Shared^.Receiver.Handle,WM_USER + code, wParam, lParam) or
(GetLastError <> ERROR_INVALID_WINDOW_HANDLE);
end;
procedure THookWrapper.CallNextHook(code: integer; wParam: WPARAM; lParam: LPARAM; var Result: LRESULT);
var
res: LRESULT;
begin
res := CallNextHookEx(Shared^.HookCallback, code, wParam, lParam);
if Result = 0 then
Result := res;
end;
constructor THookWrapper.Create(baseName: string; hookCallback: TFNHookProc);
var
wasCreated: boolean;
begin
Static.HookCallback := hookCallback;
HookMutex := CreateMutex_AllowEveryone(true, PChar(baseName + 'Mutex'));
if HookMutex = 0 then
fLastError := GetLastError
else begin
try
MemFile := CreateFileMapping_AllowEveryone(INVALID_HANDLE_VALUE, PAGE_READWRITE,
0, SizeOf(TSharedHookData), PChar(baseName + 'Shared'));
if MemFile = 0 then
fLastError := GetLastError
else begin
wasCreated := (GetLastError = NO_ERROR);
Shared := MapViewOfFile(MemFile, FILE_MAP_WRITE, 0, 0, 0);
if Shared = nil then
fLastError := GetLastError
else if wasCreated then
FillChar(Shared^, SizeOf(TSharedHookData), 0);
end;
finally ReleaseMutex(HookMutex); end;
end;
end;
destructor THookWrapper.Destroy;
begin
DetachReceiver(Receiver.Handle );
UnmapViewOfFile(Shared);
CloseHandle(MemFile);
CloseHandle(HookMutex);
inherited;
end;
function THookWrapper.DetachReceiver(receiver: THandle): integer;
begin
Result := 0;
if not assigned(Shared) then
Exit;
WaitForSingleObject(HookMutex, INFINITE);
try
if Shared^.Receiver.Handle <= 0 then
Result := ERROR_NOT_REGISTERED
else begin
if Shared^.Receiver.Handle = 0 then
Result := Unhook
else
Result := 0;
end;
finally ReleaseMutex(HookMutex); end;
end;
function THookWrapper.Hook: integer;
begin
Result := 0;
if not assigned(Shared) then
Exit;
WaitForSingleObject(HookMutex, INFINITE);
try
if Shared^.HookCallback <> 0 then
Result := ERROR_ALREADY_HOOKED
else begin
Shared^.HookCallback := SetWindowsHookEx( WH_CBT, Static.HookCallback,HInstance,0);
if Shared^.HookCallback = 0 then
Result := GetLastError;
end;
finally ReleaseMutex(HookMutex); end;
end;
function THookWrapper.Unhook: integer;
begin
Result := 0;
if not assigned(Shared) then
Exit;
WaitForSingleObject(HookMutex, INFINITE);
try
if Shared^.HookCallback <> 0 then begin
if not UnhookWindowsHookEx(Shared^.HookCallback) then
Result := GetLastError;
Shared^.HookCallback := 0;
end;
finally ReleaseMutex(HookMutex); end;
end;
end.
unit CBTSecurity;
interface
uses
Windows, JwaAclApi, JwaAccCtrl, JwaWinNT, JwaWinBase, JwaWinType;
type
PSecurityAttributes = LPSECURITY_ATTRIBUTES;
type
TcbtSecurityAttributes = class
private
gsaDacl : PACL;
gsaSecAttr : TSecurityAttributes;
gsaSecDescr: TSecurityDescriptor;
gsaSid : PSID;
protected
function GetSA: PSecurityAttributes;
public
constructor AllowAccount(const accountName: string);
constructor AllowEveryone;
constructor AllowSID(sid: PSID);
destructor Destroy; override;
property SecurityAttributes: PSecurityAttributes read GetSA;
end;
function CreateEvent_AllowAccount(const accountName: string; manualReset, initialState: boolean; const eventName: string): THandle;
function CreateEvent_AllowEveryone(manualReset, initialState: boolean; const eventName: string): THandle;
function CreateFileMapping_AllowAccount(const accountName: string; hFile: THandle; flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD;
const fileMappingName: string): THandle;
function CreateFileMapping_AllowEveryone(hFile: THandle; flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD;
const fileMappingName: string): THandle;
function CreateMutex_AllowAccount(const accountName: string; initialOwner: boolean; const mutexName: string): THandle;
function CreateMutex_AllowEveryone(initialOwner: boolean; const mutexName: string): THandle;
function CreateSemaphore_AllowAccount(const accountName: string; initialCount, maximumCount: longint; const semaphoreName: string): THandle;
function CreateSemaphore_AllowEveryone(initialCount, maximumCount: longint; const semaphoreName: string): THandle;
function GetCurrentSIDName: string;
implementation
uses
SysUtils,
// JclSecurity,
JwaSddl;
procedure FreeTokenInformation(var Buffer: Pointer);
begin
if Buffer <> nil then
FreeMem(Buffer);
Buffer := nil;
end;
procedure QueryTokenInformation(Token: THandle; InformationClass: TTokenInformationClass; var Buffer: Pointer);
var
Ret: BOOL;
Length, LastError: DWORD;
begin
Buffer := nil;
// if not IsWinNT then // Win9x/ME
// Exit;
Length := 0;
{$IFDEF FPC}
Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, @Length);
{$ELSE ~FPC}
Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, Length);
{$ENDIF ~FPC}
if (not Ret) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then
begin
GetMem(Buffer, Length);
{$IFDEF FPC}
Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, @Length);
{$ELSE ~FPC}
Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, Length);
{$ENDIF ~FPC}
if not Ret then
begin
LastError := GetLastError;
FreeTokenInformation(Buffer);
SetLastError(LastError);
end;
end;
end;
function CreateEvent_AllowAccount(const accountName: string; manualReset, initialState: boolean; const eventName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowAccount(accountName);
try
Result := CreateEvent(gsa.SecurityAttributes, manualReset, initialState, PChar(eventName));
finally FreeAndNil(gsa); end;
end;
function CreateEvent_AllowEveryone(manualReset, initialState: boolean; const eventName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowEveryone;
try
Result := CreateEvent(gsa.SecurityAttributes, manualReset, initialState, PChar(eventName));
finally FreeAndNil(gsa); end;
end;
function CreateFileMapping_AllowAccount(const accountName: string; hFile: THandle; flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD;
const fileMappingName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowAccount(accountName);
try
Result := CreateFileMapping(hFile, gsa.SecurityAttributes, flProtect,
dwMaximumSizeHigh, dwMaximumSizeLow, PChar(fileMappingName));
finally FreeAndNil(gsa); end;
end;
function CreateFileMapping_AllowEveryone(hFile: THandle; flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD;
const fileMappingName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowEveryone;
try
Result := CreateFileMapping(hFile, gsa.SecurityAttributes, flProtect,
dwMaximumSizeHigh, dwMaximumSizeLow, PChar(fileMappingName));
finally FreeAndNil(gsa); end;
end;
function CreateMutex_AllowAccount(const accountName: string; initialOwner: boolean; const mutexName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowAccount(accountName);
try
Result := CreateMutex(gsa.SecurityAttributes, initialOwner, PChar(mutexName));
finally FreeAndNil(gsa); end;
end;
function CreateMutex_AllowEveryone(initialOwner: boolean; const mutexName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowEveryone;
try
Result := CreateMutex(gsa.SecurityAttributes, initialOwner, PChar(mutexName));
finally FreeAndNil(gsa); end;
end;
function CreateSemaphore_AllowAccount(const accountName: string; initialCount, maximumCount: longint; const semaphoreName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowAccount(accountName);
try
Result := CreateSemaphore(gsa.SecurityAttributes, initialCount, maximumCount, PChar(semaphoreName));
finally FreeAndNil(gsa); end;
end;
function CreateSemaphore_AllowEveryone(initialCount, maximumCount: longint; const semaphoreName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowEveryone;
try
Result := CreateSemaphore(gsa.SecurityAttributes, initialCount, maximumCount, PChar(semaphoreName));
finally FreeAndNil(gsa); end;
end;
function GetCurrentSIDName: string;
var
hAccessToken: THandle;
hProcess : THandle;
infoBuffer : pointer;
SIDName : PChar;
begin
Result := '';
hProcess := GetCurrentProcess;
if OpenProcessToken(hProcess, TOKEN_READ, hAccessToken) then try
QueryTokenInformation(hAccessToken, TokenUser, infoBuffer);
if assigned(infoBuffer) then try
if ConvertSidToStringSid(PSIDAndAttributes(infoBuffer)^.sid, SIDName) then begin
Result := SIDName;
LocalFree(cardinal(SIDName));
end;
finally FreeMem(infoBuffer); end
finally CloseHandle(hAccessToken); end;
end;
constructor TcbtSecurityAttributes.AllowAccount(const accountName: string);
var
domain : string;
domainSize: DWORD;
sid : PSID;
sidSize : DWORD;
use : DWORD;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Exit;
domainSize := 0;
LookupAccountName(nil, PChar(accountName), nil, sidSize, nil, domainSize, use);
sid := AllocMem(sidSize);
try
SetLength(domain, domainSize);
Win32Check(LookupAccountName(nil, PChar(accountName), sid, sidSize, PChar(domain), domainSize, use));
AllowSID(sid);
finally FreeMem(sid); end;
end;
constructor TcbtSecurityAttributes.AllowEveryone;
var
siaWorld: SID_IDENTIFIER_AUTHORITY;
sid : PSID;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Exit;
siaWorld := SECURITY_WORLD_SID_AUTHORITY;
sid := AllocMem(GetSidLengthRequired(1));
try
Win32Check(InitializeSid(sid, @siaWorld, 1));
PDWORD(GetSidSubAuthority(sid, 0))^ := SECURITY_WORLD_RID;
AllowSID(sid);
finally FreeMem(sid); end;
end;
constructor TcbtSecurityAttributes.AllowSID(sid: PSID);
var
daclSize: integer;
sidSize : integer;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Exit;
sidSize := GetLengthSid(sid);
gsaSid := AllocMem(sidSize);
Move(sid^, gsaSid^, sidSize);
daclSize := SizeOf(ACL) + SizeOf(ACCESS_ALLOWED_ACE) + GetLengthSid(gsaSid);
gsaDacl := AllocMem(daclSize);
Win32Check(InitializeAcl(gsaDacl, daclSize, ACL_REVISION));
Win32Check(AddAccessAllowedAce(gsaDacl, ACL_REVISION, GENERIC_ALL, gsaSid));
Win32Check(InitializeSecurityDescriptor(@gsaSecDescr, SECURITY_DESCRIPTOR_REVISION));
Win32Check(SetSecurityDescriptorDacl(@gsaSecDescr, true, gsaDacl, false));
FillChar(gsaSecAttr, SizeOf(gsaSecAttr), 0);
gsaSecAttr.nLength := SizeOf(gsaSecAttr);
gsaSecAttr.lpSecurityDescriptor := @gsaSecDescr;
end;
destructor TcbtSecurityAttributes.Destroy;
begin
if assigned(gsaSid) then begin
FreeMem(gsaSid);
gsaSid := nil;
end;
if assigned(gsaDacl) then begin
FreeMem(gsaDacl);
gsaDacl := nil;
end;
inherited;
end;
function TcbtSecurityAttributes.GetSA: PSecurityAttributes;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
Result := @gsaSecAttr
else
Result := nil;
end;
end.
unit HookCbtComp;
interface
uses
SysUtils,
Windows,
Messages,
Classes,
Controls,
CbtCommon;
type
TCBTHookAllMessages = procedure(Sender: TObject; Code, wParam, lParam: longint) of object;
TSysHook = class(TComponent)
private
FActive : boolean;
FHookDLLName : string;
FIsFiltering : boolean;
FListenerWnd : THandle;
FOnAllCbtMessages: TCBTHookAllMessages;
procedure HookMain(var Message: TMessage);
procedure SetFiltering(const Value: boolean);
property AllowFiltering: boolean read FIsFiltering write SetFiltering;
protected
function MyName: string; virtual;
procedure ProcessMessage(var Message: TMessage); virtual; abstract;
procedure SetHookDLLName(const Value: string); virtual;
procedure AllCbtMessages(code, wParam, lParam: longint ); virtual;
public
destructor Destroy; override;
function Start: string;
procedure Stop;
property Active: boolean read FActive;
published
property HookDLL: string read FHookDLLName write SetHookDLLName;
property OnAllCbtMessages: TCBTHookAllMessages read FOnAllCbtMessages write FOnAllCbtMessages;
end;
TCBTHook = class(TSysHook)
private
protected
procedure ProcessMessage(var Message: TMessage); override;
published
end;
procedure Register;
implementation
uses
Forms,
HookCbtLoader;
const
GWL_METHODCODE = SizeOf(pointer) * 0;
GWL_METHODDATA = SizeOf(pointer) * 1;
CDSiHiddenWindowName = 'DSiUtilWindow';
var
GDSiWndHandlerCritSect: TRTLCriticalSection;
GDSiWndHandlerCount: integer;
GTerminateBackgroundTasks: THandle;
procedure Register;
begin
RegisterComponents('HOOK',[TCBTHook]);
end; { Register }
procedure DSiDeallocateHWnd(wnd: HWND);
begin
if wnd = 0 then
Exit;
DestroyWindow(wnd);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
Dec(GDSiWndHandlerCount);
if GDSiWndHandlerCount <= 0 then
{$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end;
function DSiClassWndProc(Window: HWND; Message, WParam, LParam: longint): longint; stdcall;
var
instanceWndProc: TMethod;
msg : TMessage;
begin
{$IFDEF CPUX64}
instanceWndProc.Code := pointer(GetWindowLongPtr(Window, GWL_METHODCODE));
instanceWndProc.Data := pointer(GetWindowLongPtr(Window, GWL_METHODDATA));
{$ELSE}
instanceWndProc.Code := pointer(GetWindowLong(Window, GWL_METHODCODE));
instanceWndProc.Data := pointer(GetWindowLong(Window, GWL_METHODDATA));
{$ENDIF ~CPUX64}
if Assigned(TWndMethod(instanceWndProc)) then
begin
msg.msg := Message;
msg.wParam := WParam;
msg.lParam := LParam;
msg.Result := 0;
TWndMethod(instanceWndProc)(msg);
Result := msg.Result
end
else
Result := DefWindowProc(Window, Message, WParam,LParam);
end; { DSiClassWndProc }
function DSiAllocateHWnd(wndProcMethod: TWndMethod): HWND;
var
alreadyRegistered: boolean;
tempClass : TWndClass;
utilWindowClass : TWndClass;
begin
Result := 0;
FillChar(utilWindowClass, SizeOf(utilWindowClass), 0);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
alreadyRegistered := GetClassInfo(HInstance, CDSiHiddenWindowName, tempClass);
if (not alreadyRegistered) or (tempClass.lpfnWndProc <> @DSiClassWndProc) then begin
if alreadyRegistered then
{$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
utilWindowClass.lpszClassName := CDSiHiddenWindowName;
utilWindowClass.hInstance := HInstance;
utilWindowClass.lpfnWndProc := @DSiClassWndProc;
utilWindowClass.cbWndExtra := SizeOf(TMethod);
if {$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.RegisterClass(utilWindowClass) = 0 then
raise Exception.CreateFmt('Unable to register DSiWin32 hidden window class. %s',
[SysErrorMessage(GetLastError)]);
end;
Result := CreateWindowEx(WS_EX_TOOLWINDOW, CDSiHiddenWindowName, '', WS_POPUP,
0, 0, 0, 0, 0, 0, HInstance, nil);
if Result = 0 then
raise Exception.CreateFmt('Unable to create DSiWin32 hidden window. %s',
[SysErrorMessage(GetLastError)]);
{$IFDEF CPUX64}
SetWindowLongPtr(Result, GWL_METHODDATA, NativeInt(TMethod(wndProcMethod).Data));
SetWindowLongPtr(Result, GWL_METHODCODE, NativeInt(TMethod(wndProcMethod).Code));
{$ELSE}
SetWindowLong(Result, GWL_METHODDATA, cardinal(TMethod(wndProcMethod).Data));
SetWindowLong(Result, GWL_METHODCODE, cardinal(TMethod(wndProcMethod).Code));
{$ENDIF ~CPUX64}
Inc(GDSiWndHandlerCount);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end;
destructor TSysHook.Destroy;
begin
Stop;
inherited;
end;
procedure TSysHook.AllCbtMessages (code, wParam, lParam: longint);
begin
if assigned(FOnAllCbtMessages) then
FOnAllCbtMessages(Self,code,wParam,lParam);
end;
procedure TSysHook.HookMain(var Message: TMessage);
begin
if Message.Msg < WM_USER then
with Message do
Result := DefWindowProc(FListenerWnd, Msg, wParam, lParam)
else
ProcessMessage(Message);
end;
//Solo per error reporting.
function TSysHook.MyName: string;
begin
if Name <> '' then
Result := Name
else
Result := ClassName;
end;
procedure TSysHook.SetFiltering(const Value: boolean);
begin
if Active then
raise Exception.Create('CBT HOOK is active!');
FIsFiltering := Value;
end;
// Setta il nome della DLL
procedure TSysHook.SetHookDLLName(const Value: string);
begin
if FActive then
MessageBox(0, PChar('can''t change DLL name while cbt hook is active!'),
PChar(MyName), MB_OK + MB_ICONERROR)
else
FHookDLLName := Value;
end;
function TSysHook.Start: string;
var
hookRes: integer;
begin
if not FActive then begin
if FHookDLLName = '' then
Result := 'Missing DLL name!'
else begin
hookRes := LoadHookDLL(FHookDllName);
if hookRes <> 0 then
Result := HookError(hookRes)
else begin
FListenerWnd := DSiAllocateHwnd(HookMain);
if FListenerWnd = 0 then
Result := 'Listener Error'
else begin
hookRes := CbtfnAttachReceiver(FListenerWnd,FIsFiltering);
if hookRes <> 0 then begin
DSiDeallocateHWnd(FListenerWnd);
FListenerWnd := 0;
Result := HookError(hookRes);
end
else begin
Result := '';
FActive := true;
end;
end;
end;
end;
end;
end;
procedure TSysHook.Stop;
begin
if FActive then begin
if FListenerWnd <> 0 then begin
DSiDeallocateHWnd(FListenerWnd);
FListenerWnd := 0;
end;
UnloadHookDLL;
FActive := false;
end;
end;
procedure TCBTHook.ProcessMessage(var Message: TMessage);
var
code : DWORD;
flags : byte;
repeatCount: word;
scanCode : byte;
begin
if Message.Msg >= WM_USER then begin
Message.Result := 0;
code := Message.msg-WM_USER;
AllCbtMessages(code,Message.wParam,Message.lParam); // nessun filtro. Tutti i messaggi
end;
end;
initialization
InitializeCriticalSection(GDSiWndHandlerCritSect);
GDSiWndHandlerCount := 0;
finalization
DeleteCriticalSection(GDSiWndHandlerCritSect);
end.
tipo HCBT_CREATEWND, HCBT_ACTIVATE. Per una lista completa vedere qui. In realtà al nostro client non serve discernere quale messaggio sia stato ricevuto ma se anche solo un messaggio è stato ricevuto. Sulla base del lavoro di Primož Gabrijelčič ho creato un hook che si occupi solo di mandare il messaggio al componente sulla Form, senza alcun filtro. Il componente deve solo settare la dll che intende utilizzare e ha un solo evento che riceve i messaggi cbt.
il parametro importante è lparam perchè contiene l'handle della finestra. Con l'handle è possibile agire per ottenere ulteriori informazioni:
var
C: array[0..16384] of Char;
PID: UINT;
buf: Array [0..255] of char;
begin
SendMessage( W, WM_GETTEXT, 256, integer(@C));
GetWindowThreadProcessID(W,@PID);
GetClassName( W, Buf, 256);
Caption:=string(Buf);
Per quanto riguarda l'Hook di Mouse è sufficiente una copia perfetta di questo sorgente con riferimento ai messaggi WH_MOUSE. Quello che è molto importante quando si scrive un hook è di non portarsi dietro intere librerie di sistema solo per sfruttare una singola funzione. In questo caso le funzioni:
function StrScan(const Str: PChar; Chr: Char): PChar; assembler;
function LastDelimiter(const Delimiters, S: string): Integer;
function ExtractFileName(const FileName: string): string;
function ChangeFileExt(const FileName, Extension: string): string;
sono copiate dalla sysutils di Delphi ( possono variare da versione a versione ). Importarle ci evita tutta una serie di problemi legati all'exception handle durante il loading. Lo stesso concetto si applica per le procedure
procedure FreeTokenInformation(var Buffer: Pointer);
procedure QueryTokenInformation(Token: THandle; InformationClass: TTokenInformationClass; var Buffer: Pointer);
che appartengono a jclSecurity.pas (Jedi library),
Inoltre le seguenti
function DSiClassWndProc(Window: HWND; Message, WParam, LParam: longint): longint; stdcall;
procedure DSiDeallocateHWnd(wnd: HWND);
function DSiAllocateHWnd(wndProcMethod: TWndMethod): HWND;
sono importate dalla relativa unit sempre di Primož Gabrijelčič .
Inoltre le seguenti
function DSiClassWndProc(Window: HWND; Message, WParam, LParam: longint): longint; stdcall;
procedure DSiDeallocateHWnd(wnd: HWND);
function DSiAllocateHWnd(wndProcMethod: TWndMethod): HWND;
sono importate dalla relativa unit sempre di Primož Gabrijelčič .
In ultima analisi potremmo addirittura permetterci di lavorare con una variabile locale alla dll che eviti l'invio di messaggi al ricevente ( il TComponent sulla form ) se provenienti dalla stessa finestra quindi con lo stesso Handle. Se dobbiamo solo chiudere le finestre dobbiamo solo sapere della loro esistenza, non di tutto quello che succede. Ancora più opportuno unificare hook CBT e MOUSE per non ricevere troppi messaggi. La variabile può essere gestita nella procedure TCBTHook.ProcessMessage(var Message: TMessage);
library HookCbtkDLL;
uses
Windows,
cbt in 'cbt.pas',
CbtCommon in 'CbtCommon.pas';
procedure DLLEntryPoint(reason: integer);
begin
if reason = DLL_PROCESS_DETACH then
Cbt.ProcessDetached;
end; { DLLEntryPoint }
exports
AttachReceiver,
DetachReceiver,
LastError;
begin
DisableThreadLibraryCalls(HInstance);
Cbt.ProcessAttached;
DLLProc := @DLLEntryPoint;
end.
unit Cbt;
interface
uses
Windows,
Messages,
CbtCommon ;
procedure ProcessAttached;
procedure ProcessDetached;
function AttachReceiver(receiver: THandle; Filter: boolean): integer; stdcall;
function DetachReceiver( receiver: THandle): integer; stdcall;
function LastError: DWORD; stdcall;
implementation
uses
CbtSecurity;
type
THookReceiver = record
Filtering: boolean;
Handle : THandle;
end;
TSharedHookData = record
HookCallback : HHOOK;
Receiver : THookReceiver;
end;
PSharedHookData = ^TSharedHookData;
TStaticHookData = record
HookCallback: TFNHookProc;
end;
type
THookWrapper = class
private
HookMutex: THandle;
fLastError: DWORD;
MemFile : THandle;
Receiver: THookReceiver; // il Tcomponent
Shared : PSharedHookData; // memory mapped file
Static : TStaticHookData;
protected
function Hook: integer; virtual;
function Unhook: integer; virtual;
public
constructor Create(baseName: string; hookCallback: TFNHookProc);
destructor Destroy; override;
function AttachReceiver(receiver: THandle; Filter: boolean): integer;
function DetachReceiver(receiver: THandle): integer;
procedure input(code: integer; wParam: WPARAM; lParam: LPARAM; var Result: LRESULT);
procedure CallNextHook(code: integer; wParam: WPARAM; lParam: LPARAM; var Result: LRESULT);
property LastError: DWORD read fLastError;
end;
var
Wrapper: THookWrapper;
function CBTHookCallback(code: integer; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall;
begin
Result := 0;
if assigned(wrapper) and assigned(wrapper.Shared) then begin
WaitForSingleObject(wrapper.HookMutex, INFINITE);
try
if code = HCBT_ACTIVATE then
Wrapper.input(code,wParam,PCBTActivateStruct(lParam)^.hWndActive, Result)
else if code = HCBT_CLICKSKIPPED then
Wrapper.input(code,wParam,PMouseHookStruct(lParam)^.hwnd,Result)
else if code >=0 then
Wrapper.input(code,wParam,lParam,Result);
finally ReleaseMutex(wrapper.HookMutex); end;
Wrapper.CallNextHook(code,wParam,lParam,Result);
end;
end;
(*Copiate da SysUtils *)
function StrScan(const Str: PChar; Chr: Char): PChar; assembler;
asm
PUSH EDI
PUSH EAX
MOV EDI,Str
MOV ECX,0FFFFFFFFH
XOR AL,AL
REPNE SCASB
NOT ECX
POP EDI
MOV AX,Chr//GG
REPNE SCASB
MOV EAX,0
JNE @@1
MOV EAX,EDI
DEC EAX
@@1: POP EDI
end;
function LastDelimiter(const Delimiters, S: string): Integer;
var
P: PChar;
begin
Result := Length(S);
P := PChar(Delimiters);
while Result > 0 do begin
if (S[Result] <> #0) and (StrScan(P, S[Result]) <> nil) then
Exit;
Dec(Result);
end;
end;
function ExtractFileName(const FileName: string): string;
var
I: Integer;
begin
I := LastDelimiter('\:', FileName);
Result := Copy(FileName, I + 1, MaxInt);
end;
function ChangeFileExt(const FileName, Extension: string): string;
var
I: Integer;
begin
I := LastDelimiter('.\:',Filename);
if (I = 0) or (FileName[I] <> '.') then I := MaxInt;
Result := Copy(FileName, 1, I - 1) + Extension;
end;
(*fine copia SysUtils*)
procedure ProcessAttached;
var
hBaseName: array [0..MAX_PATH] of char;
strBaseName: string;
begin
if GetModuleFileName(HInstance, hBaseName, SizeOf(hBaseName)-1)= 0 then begin
MessageBox(0,'Hook','Failed to retrieve own module name!',MB_OK);
Halt;
end;
strBaseName := '_HOOK_'+ChangeFileExt(ExtractFileName(hBaseName),'')+'_';
Wrapper := THookWrapper.Create(strBaseName+'CBTALLMESSAGES', @CBTHookCallback);
end;
procedure ProcessDetached;
begin
wrapper.Free;
end;
function AttachReceiver(receiver: THandle; Filter: boolean): integer; stdcall;
begin
Result := Wrapper.AttachReceiver(receiver,Filter);
end;
function DetachReceiver( receiver: THandle): integer; stdcall;
begin
Result := Wrapper.DetachReceiver(receiver);
end;
function LastError: DWORD; stdcall;
begin
Result := Wrapper.LastError;
end;
function THookWrapper.AttachReceiver(receiver: THandle; Filter: boolean): integer;
begin
Result := 0;
if not assigned(Shared) then
Exit;
WaitForSingleObject(HookMutex, INFINITE);
try
if Shared^.Receiver.Handle <> 0 then Result := ERROR_TOO_MANY_RECEIVERS;
Shared^.Receiver.Handle := receiver;
Shared^.Receiver.Filtering := Filter;
if Shared^.Receiver.Handle <> 0 then // installo l'hook sul primo receiver
Result := Hook
else
Result := ERROR_NO_ERROR;
finally ReleaseMutex(HookMutex); end;
end;
procedure THookWrapper.input(code: integer; wParam: WPARAM; lParam: LPARAM; var Result: LRESULT);
var
msgRes : DWORD;
MsgSent : boolean;
begin
if Shared^.Receiver.Filtering then begin
MsgSent := SendMessageTimeout(Shared^.Receiver.Handle, WM_USER + code, wParam, lParam,
SMTO_ABORTIFHUNG OR SMTO_BLOCK, 5000{ms}, msgRes) <> 0;
if Result = 0 then
Result := msgRes;
end
else
MsgSent := PostMessage(Shared^.Receiver.Handle,WM_USER + code, wParam, lParam) or
(GetLastError <> ERROR_INVALID_WINDOW_HANDLE);
end;
procedure THookWrapper.CallNextHook(code: integer; wParam: WPARAM; lParam: LPARAM; var Result: LRESULT);
var
res: LRESULT;
begin
res := CallNextHookEx(Shared^.HookCallback, code, wParam, lParam);
if Result = 0 then
Result := res;
end;
constructor THookWrapper.Create(baseName: string; hookCallback: TFNHookProc);
var
wasCreated: boolean;
begin
Static.HookCallback := hookCallback;
HookMutex := CreateMutex_AllowEveryone(true, PChar(baseName + 'Mutex'));
if HookMutex = 0 then
fLastError := GetLastError
else begin
try
MemFile := CreateFileMapping_AllowEveryone(INVALID_HANDLE_VALUE, PAGE_READWRITE,
0, SizeOf(TSharedHookData), PChar(baseName + 'Shared'));
if MemFile = 0 then
fLastError := GetLastError
else begin
wasCreated := (GetLastError = NO_ERROR);
Shared := MapViewOfFile(MemFile, FILE_MAP_WRITE, 0, 0, 0);
if Shared = nil then
fLastError := GetLastError
else if wasCreated then
FillChar(Shared^, SizeOf(TSharedHookData), 0);
end;
finally ReleaseMutex(HookMutex); end;
end;
end;
destructor THookWrapper.Destroy;
begin
DetachReceiver(Receiver.Handle );
UnmapViewOfFile(Shared);
CloseHandle(MemFile);
CloseHandle(HookMutex);
inherited;
end;
function THookWrapper.DetachReceiver(receiver: THandle): integer;
begin
Result := 0;
if not assigned(Shared) then
Exit;
WaitForSingleObject(HookMutex, INFINITE);
try
if Shared^.Receiver.Handle <= 0 then
Result := ERROR_NOT_REGISTERED
else begin
if Shared^.Receiver.Handle = 0 then
Result := Unhook
else
Result := 0;
end;
finally ReleaseMutex(HookMutex); end;
end;
function THookWrapper.Hook: integer;
begin
Result := 0;
if not assigned(Shared) then
Exit;
WaitForSingleObject(HookMutex, INFINITE);
try
if Shared^.HookCallback <> 0 then
Result := ERROR_ALREADY_HOOKED
else begin
Shared^.HookCallback := SetWindowsHookEx( WH_CBT, Static.HookCallback,HInstance,0);
if Shared^.HookCallback = 0 then
Result := GetLastError;
end;
finally ReleaseMutex(HookMutex); end;
end;
function THookWrapper.Unhook: integer;
begin
Result := 0;
if not assigned(Shared) then
Exit;
WaitForSingleObject(HookMutex, INFINITE);
try
if Shared^.HookCallback <> 0 then begin
if not UnhookWindowsHookEx(Shared^.HookCallback) then
Result := GetLastError;
Shared^.HookCallback := 0;
end;
finally ReleaseMutex(HookMutex); end;
end;
end.
unit cbtCommon;
interface
uses
Windows;
const
ERROR_FIRST = 0;
ERROR_NO_ERROR = ERROR_FIRST;
ERROR_EXPORTS = ERROR_NO_ERROR-1;
ERRROR_ALREADY_REGISTERED = ERROR_EXPORTS-1;
ERROR_NOT_REGISTERED = ERRROR_ALREADY_REGISTERED-1;
ERROR_TOO_MANY_RECEIVERS = ERROR_NOT_REGISTERED-1;
ERROR_ALREADY_HOOKED = ERROR_TOO_MANY_RECEIVERS-1;
LAST_ERROR = ERROR_ALREADY_HOOKED;
var
HookErrors: array [LAST_ERROR..ERROR_FIRST] of string;
implementation
resourcestring
sNoError = 'No error.';
sNoExports = 'error exporting functions.';
sAlreadyRegistered = 'Receiver already registered.';
sNotRegistered = 'Receiver not registered.';
sTooManyReceivers = 'Too many receivers.';
sAlreadyHooked = 'System hook already active.';
initialization
HookErrors[ERROR_NO_ERROR] := sNoError;
HookErrors[ERROR_EXPORTS] := sNoExports;
HookErrors[ERRROR_ALREADY_REGISTERED]:= sAlreadyRegistered;
HookErrors[ERROR_NOT_REGISTERED] := sNotRegistered;
HookErrors[ERROR_TOO_MANY_RECEIVERS] := sTooManyReceivers;
HookErrors[ERROR_ALREADY_HOOKED] := sAlreadyHooked;
end.
unit CBTSecurity;
interface
uses
Windows, JwaAclApi, JwaAccCtrl, JwaWinNT, JwaWinBase, JwaWinType;
type
PSecurityAttributes = LPSECURITY_ATTRIBUTES;
type
TcbtSecurityAttributes = class
private
gsaDacl : PACL;
gsaSecAttr : TSecurityAttributes;
gsaSecDescr: TSecurityDescriptor;
gsaSid : PSID;
protected
function GetSA: PSecurityAttributes;
public
constructor AllowAccount(const accountName: string);
constructor AllowEveryone;
constructor AllowSID(sid: PSID);
destructor Destroy; override;
property SecurityAttributes: PSecurityAttributes read GetSA;
end;
function CreateEvent_AllowAccount(const accountName: string; manualReset, initialState: boolean; const eventName: string): THandle;
function CreateEvent_AllowEveryone(manualReset, initialState: boolean; const eventName: string): THandle;
function CreateFileMapping_AllowAccount(const accountName: string; hFile: THandle; flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD;
const fileMappingName: string): THandle;
function CreateFileMapping_AllowEveryone(hFile: THandle; flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD;
const fileMappingName: string): THandle;
function CreateMutex_AllowAccount(const accountName: string; initialOwner: boolean; const mutexName: string): THandle;
function CreateMutex_AllowEveryone(initialOwner: boolean; const mutexName: string): THandle;
function CreateSemaphore_AllowAccount(const accountName: string; initialCount, maximumCount: longint; const semaphoreName: string): THandle;
function CreateSemaphore_AllowEveryone(initialCount, maximumCount: longint; const semaphoreName: string): THandle;
function GetCurrentSIDName: string;
implementation
uses
SysUtils,
// JclSecurity,
JwaSddl;
procedure FreeTokenInformation(var Buffer: Pointer);
begin
if Buffer <> nil then
FreeMem(Buffer);
Buffer := nil;
end;
procedure QueryTokenInformation(Token: THandle; InformationClass: TTokenInformationClass; var Buffer: Pointer);
var
Ret: BOOL;
Length, LastError: DWORD;
begin
Buffer := nil;
// if not IsWinNT then // Win9x/ME
// Exit;
Length := 0;
{$IFDEF FPC}
Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, @Length);
{$ELSE ~FPC}
Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, Length);
{$ENDIF ~FPC}
if (not Ret) and (GetLastError = ERROR_INSUFFICIENT_BUFFER) then
begin
GetMem(Buffer, Length);
{$IFDEF FPC}
Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, @Length);
{$ELSE ~FPC}
Ret := GetTokenInformation(Token, InformationClass, Buffer, Length, Length);
{$ENDIF ~FPC}
if not Ret then
begin
LastError := GetLastError;
FreeTokenInformation(Buffer);
SetLastError(LastError);
end;
end;
end;
function CreateEvent_AllowAccount(const accountName: string; manualReset, initialState: boolean; const eventName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowAccount(accountName);
try
Result := CreateEvent(gsa.SecurityAttributes, manualReset, initialState, PChar(eventName));
finally FreeAndNil(gsa); end;
end;
function CreateEvent_AllowEveryone(manualReset, initialState: boolean; const eventName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowEveryone;
try
Result := CreateEvent(gsa.SecurityAttributes, manualReset, initialState, PChar(eventName));
finally FreeAndNil(gsa); end;
end;
function CreateFileMapping_AllowAccount(const accountName: string; hFile: THandle; flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD;
const fileMappingName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowAccount(accountName);
try
Result := CreateFileMapping(hFile, gsa.SecurityAttributes, flProtect,
dwMaximumSizeHigh, dwMaximumSizeLow, PChar(fileMappingName));
finally FreeAndNil(gsa); end;
end;
function CreateFileMapping_AllowEveryone(hFile: THandle; flProtect, dwMaximumSizeHigh, dwMaximumSizeLow: DWORD;
const fileMappingName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowEveryone;
try
Result := CreateFileMapping(hFile, gsa.SecurityAttributes, flProtect,
dwMaximumSizeHigh, dwMaximumSizeLow, PChar(fileMappingName));
finally FreeAndNil(gsa); end;
end;
function CreateMutex_AllowAccount(const accountName: string; initialOwner: boolean; const mutexName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowAccount(accountName);
try
Result := CreateMutex(gsa.SecurityAttributes, initialOwner, PChar(mutexName));
finally FreeAndNil(gsa); end;
end;
function CreateMutex_AllowEveryone(initialOwner: boolean; const mutexName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowEveryone;
try
Result := CreateMutex(gsa.SecurityAttributes, initialOwner, PChar(mutexName));
finally FreeAndNil(gsa); end;
end;
function CreateSemaphore_AllowAccount(const accountName: string; initialCount, maximumCount: longint; const semaphoreName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowAccount(accountName);
try
Result := CreateSemaphore(gsa.SecurityAttributes, initialCount, maximumCount, PChar(semaphoreName));
finally FreeAndNil(gsa); end;
end;
function CreateSemaphore_AllowEveryone(initialCount, maximumCount: longint; const semaphoreName: string): THandle;
var
gsa: TcbtSecurityAttributes;
begin
gsa := TcbtSecurityAttributes.AllowEveryone;
try
Result := CreateSemaphore(gsa.SecurityAttributes, initialCount, maximumCount, PChar(semaphoreName));
finally FreeAndNil(gsa); end;
end;
function GetCurrentSIDName: string;
var
hAccessToken: THandle;
hProcess : THandle;
infoBuffer : pointer;
SIDName : PChar;
begin
Result := '';
hProcess := GetCurrentProcess;
if OpenProcessToken(hProcess, TOKEN_READ, hAccessToken) then try
QueryTokenInformation(hAccessToken, TokenUser, infoBuffer);
if assigned(infoBuffer) then try
if ConvertSidToStringSid(PSIDAndAttributes(infoBuffer)^.sid, SIDName) then begin
Result := SIDName;
LocalFree(cardinal(SIDName));
end;
finally FreeMem(infoBuffer); end
finally CloseHandle(hAccessToken); end;
end;
constructor TcbtSecurityAttributes.AllowAccount(const accountName: string);
var
domain : string;
domainSize: DWORD;
sid : PSID;
sidSize : DWORD;
use : DWORD;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Exit;
domainSize := 0;
LookupAccountName(nil, PChar(accountName), nil, sidSize, nil, domainSize, use);
sid := AllocMem(sidSize);
try
SetLength(domain, domainSize);
Win32Check(LookupAccountName(nil, PChar(accountName), sid, sidSize, PChar(domain), domainSize, use));
AllowSID(sid);
finally FreeMem(sid); end;
end;
constructor TcbtSecurityAttributes.AllowEveryone;
var
siaWorld: SID_IDENTIFIER_AUTHORITY;
sid : PSID;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Exit;
siaWorld := SECURITY_WORLD_SID_AUTHORITY;
sid := AllocMem(GetSidLengthRequired(1));
try
Win32Check(InitializeSid(sid, @siaWorld, 1));
PDWORD(GetSidSubAuthority(sid, 0))^ := SECURITY_WORLD_RID;
AllowSID(sid);
finally FreeMem(sid); end;
end;
constructor TcbtSecurityAttributes.AllowSID(sid: PSID);
var
daclSize: integer;
sidSize : integer;
begin
if Win32Platform <> VER_PLATFORM_WIN32_NT then
Exit;
sidSize := GetLengthSid(sid);
gsaSid := AllocMem(sidSize);
Move(sid^, gsaSid^, sidSize);
daclSize := SizeOf(ACL) + SizeOf(ACCESS_ALLOWED_ACE) + GetLengthSid(gsaSid);
gsaDacl := AllocMem(daclSize);
Win32Check(InitializeAcl(gsaDacl, daclSize, ACL_REVISION));
Win32Check(AddAccessAllowedAce(gsaDacl, ACL_REVISION, GENERIC_ALL, gsaSid));
Win32Check(InitializeSecurityDescriptor(@gsaSecDescr, SECURITY_DESCRIPTOR_REVISION));
Win32Check(SetSecurityDescriptorDacl(@gsaSecDescr, true, gsaDacl, false));
FillChar(gsaSecAttr, SizeOf(gsaSecAttr), 0);
gsaSecAttr.nLength := SizeOf(gsaSecAttr);
gsaSecAttr.lpSecurityDescriptor := @gsaSecDescr;
end;
destructor TcbtSecurityAttributes.Destroy;
begin
if assigned(gsaSid) then begin
FreeMem(gsaSid);
gsaSid := nil;
end;
if assigned(gsaDacl) then begin
FreeMem(gsaDacl);
gsaDacl := nil;
end;
inherited;
end;
function TcbtSecurityAttributes.GetSA: PSecurityAttributes;
begin
if Win32Platform = VER_PLATFORM_WIN32_NT then
Result := @gsaSecAttr
else
Result := nil;
end;
end.
unit HookCbtComp;
interface
uses
SysUtils,
Windows,
Messages,
Classes,
Controls,
CbtCommon;
type
TCBTHookAllMessages = procedure(Sender: TObject; Code, wParam, lParam: longint) of object;
TSysHook = class(TComponent)
private
FActive : boolean;
FHookDLLName : string;
FIsFiltering : boolean;
FListenerWnd : THandle;
FOnAllCbtMessages: TCBTHookAllMessages;
procedure HookMain(var Message: TMessage);
procedure SetFiltering(const Value: boolean);
property AllowFiltering: boolean read FIsFiltering write SetFiltering;
protected
function MyName: string; virtual;
procedure ProcessMessage(var Message: TMessage); virtual; abstract;
procedure SetHookDLLName(const Value: string); virtual;
procedure AllCbtMessages(code, wParam, lParam: longint ); virtual;
public
destructor Destroy; override;
function Start: string;
procedure Stop;
property Active: boolean read FActive;
published
property HookDLL: string read FHookDLLName write SetHookDLLName;
property OnAllCbtMessages: TCBTHookAllMessages read FOnAllCbtMessages write FOnAllCbtMessages;
end;
TCBTHook = class(TSysHook)
private
protected
procedure ProcessMessage(var Message: TMessage); override;
published
end;
procedure Register;
implementation
uses
Forms,
HookCbtLoader;
const
GWL_METHODCODE = SizeOf(pointer) * 0;
GWL_METHODDATA = SizeOf(pointer) * 1;
CDSiHiddenWindowName = 'DSiUtilWindow';
var
GDSiWndHandlerCritSect: TRTLCriticalSection;
GDSiWndHandlerCount: integer;
GTerminateBackgroundTasks: THandle;
procedure Register;
begin
RegisterComponents('HOOK',[TCBTHook]);
end; { Register }
procedure DSiDeallocateHWnd(wnd: HWND);
begin
if wnd = 0 then
Exit;
DestroyWindow(wnd);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
Dec(GDSiWndHandlerCount);
if GDSiWndHandlerCount <= 0 then
{$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end;
function DSiClassWndProc(Window: HWND; Message, WParam, LParam: longint): longint; stdcall;
var
instanceWndProc: TMethod;
msg : TMessage;
begin
{$IFDEF CPUX64}
instanceWndProc.Code := pointer(GetWindowLongPtr(Window, GWL_METHODCODE));
instanceWndProc.Data := pointer(GetWindowLongPtr(Window, GWL_METHODDATA));
{$ELSE}
instanceWndProc.Code := pointer(GetWindowLong(Window, GWL_METHODCODE));
instanceWndProc.Data := pointer(GetWindowLong(Window, GWL_METHODDATA));
{$ENDIF ~CPUX64}
if Assigned(TWndMethod(instanceWndProc)) then
begin
msg.msg := Message;
msg.wParam := WParam;
msg.lParam := LParam;
msg.Result := 0;
TWndMethod(instanceWndProc)(msg);
Result := msg.Result
end
else
Result := DefWindowProc(Window, Message, WParam,LParam);
end; { DSiClassWndProc }
function DSiAllocateHWnd(wndProcMethod: TWndMethod): HWND;
var
alreadyRegistered: boolean;
tempClass : TWndClass;
utilWindowClass : TWndClass;
begin
Result := 0;
FillChar(utilWindowClass, SizeOf(utilWindowClass), 0);
EnterCriticalSection(GDSiWndHandlerCritSect);
try
alreadyRegistered := GetClassInfo(HInstance, CDSiHiddenWindowName, tempClass);
if (not alreadyRegistered) or (tempClass.lpfnWndProc <> @DSiClassWndProc) then begin
if alreadyRegistered then
{$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.UnregisterClass(CDSiHiddenWindowName, HInstance);
utilWindowClass.lpszClassName := CDSiHiddenWindowName;
utilWindowClass.hInstance := HInstance;
utilWindowClass.lpfnWndProc := @DSiClassWndProc;
utilWindowClass.cbWndExtra := SizeOf(TMethod);
if {$IFDEF ScopedUnitNames}Winapi.{$ENDIF}Windows.RegisterClass(utilWindowClass) = 0 then
raise Exception.CreateFmt('Unable to register DSiWin32 hidden window class. %s',
[SysErrorMessage(GetLastError)]);
end;
Result := CreateWindowEx(WS_EX_TOOLWINDOW, CDSiHiddenWindowName, '', WS_POPUP,
0, 0, 0, 0, 0, 0, HInstance, nil);
if Result = 0 then
raise Exception.CreateFmt('Unable to create DSiWin32 hidden window. %s',
[SysErrorMessage(GetLastError)]);
{$IFDEF CPUX64}
SetWindowLongPtr(Result, GWL_METHODDATA, NativeInt(TMethod(wndProcMethod).Data));
SetWindowLongPtr(Result, GWL_METHODCODE, NativeInt(TMethod(wndProcMethod).Code));
{$ELSE}
SetWindowLong(Result, GWL_METHODDATA, cardinal(TMethod(wndProcMethod).Data));
SetWindowLong(Result, GWL_METHODCODE, cardinal(TMethod(wndProcMethod).Code));
{$ENDIF ~CPUX64}
Inc(GDSiWndHandlerCount);
finally LeaveCriticalSection(GDSiWndHandlerCritSect); end;
end;
destructor TSysHook.Destroy;
begin
Stop;
inherited;
end;
procedure TSysHook.AllCbtMessages (code, wParam, lParam: longint);
begin
if assigned(FOnAllCbtMessages) then
FOnAllCbtMessages(Self,code,wParam,lParam);
end;
procedure TSysHook.HookMain(var Message: TMessage);
begin
if Message.Msg < WM_USER then
with Message do
Result := DefWindowProc(FListenerWnd, Msg, wParam, lParam)
else
ProcessMessage(Message);
end;
//Solo per error reporting.
function TSysHook.MyName: string;
begin
if Name <> '' then
Result := Name
else
Result := ClassName;
end;
procedure TSysHook.SetFiltering(const Value: boolean);
begin
if Active then
raise Exception.Create('CBT HOOK is active!');
FIsFiltering := Value;
end;
// Setta il nome della DLL
procedure TSysHook.SetHookDLLName(const Value: string);
begin
if FActive then
MessageBox(0, PChar('can''t change DLL name while cbt hook is active!'),
PChar(MyName), MB_OK + MB_ICONERROR)
else
FHookDLLName := Value;
end;
function TSysHook.Start: string;
var
hookRes: integer;
begin
if not FActive then begin
if FHookDLLName = '' then
Result := 'Missing DLL name!'
else begin
hookRes := LoadHookDLL(FHookDllName);
if hookRes <> 0 then
Result := HookError(hookRes)
else begin
FListenerWnd := DSiAllocateHwnd(HookMain);
if FListenerWnd = 0 then
Result := 'Listener Error'
else begin
hookRes := CbtfnAttachReceiver(FListenerWnd,FIsFiltering);
if hookRes <> 0 then begin
DSiDeallocateHWnd(FListenerWnd);
FListenerWnd := 0;
Result := HookError(hookRes);
end
else begin
Result := '';
FActive := true;
end;
end;
end;
end;
end;
end;
procedure TSysHook.Stop;
begin
if FActive then begin
if FListenerWnd <> 0 then begin
DSiDeallocateHWnd(FListenerWnd);
FListenerWnd := 0;
end;
UnloadHookDLL;
FActive := false;
end;
end;
procedure TCBTHook.ProcessMessage(var Message: TMessage);
var
code : DWORD;
flags : byte;
repeatCount: word;
scanCode : byte;
begin
if Message.Msg >= WM_USER then begin
Message.Result := 0;
code := Message.msg-WM_USER;
AllCbtMessages(code,Message.wParam,Message.lParam); // nessun filtro. Tutti i messaggi
end;
end;
initialization
InitializeCriticalSection(GDSiWndHandlerCritSect);
GDSiWndHandlerCount := 0;
finalization
DeleteCriticalSection(GDSiWndHandlerCritSect);
end.
unit HookCbtLoader;
interface
uses
Windows,
CbtCommon;
type
TCbtFNAttachReceiver = function ( receiver: THandle; isFiltering: boolean): integer; stdcall;
TCbtFNDetachReceiver = function ( receiver: THandle): integer; stdcall;
TCbtFNLastError = function (): DWORD; stdcall;
var
// Setto i puntatori alle funzioni di attach, detach e Lasterror
CbtfnAttachReceiver: TCbtFNAttachReceiver;
CbtfnDetachReceiver: TCbtFNDetachReceiver;
CbtfnLastError : TCbtFNLastError;
function LoadHookDLL(dllName: string): integer;
procedure UnloadHookDLL;
function HookError(errorCode: integer): string;
implementation
uses
SysUtils;
var
dllHandle: HINST;
dllCount : integer;
function LoadHookDLL(dllName: string): integer;
begin
if dllHandle = 0 then begin
dllHandle := LoadLibrary(PChar(dllName));
if (dllHandle = 0) and (not SameText(ExtractFileExt(dllName),'.dll')) then
dllHandle := LoadLibrary(PChar(ChangeFileExt(dllName,'.dll')));
if dllHandle = 0 then
Result := GetLastError
else begin
Inc(dllCount);
@CbtfnAttachReceiver := GetProcAddress(dllHandle,'AttachReceiver'); // setto gli address
@CbtfnDetachReceiver := GetProcAddress(dllHandle,'DetachReceiver');
@CbtfnLastError := GetProcAddress(dllHandle,'LastError');
if (@CbtfnAttachReceiver = nil) or
(@CbtfnDetachReceiver = nil) or
(@CbtfnLastError = nil) then
begin
Result := ERROR_EXPORTS;
UnloadHookDLL;
end
else
Result := 0;
end;
end
else begin
Inc(dllCount);
Result := 0;
end;
end;
procedure UnloadHookDLL;
begin
if dllHandle <> 0 then begin
Dec(dllCount);
if dllCount <= 0 then begin
FreeLibrary(dllHandle);
dllHandle := 0;
dllCount := 0;
@CbtfnAttachReceiver := nil;
@CbtfnDetachReceiver := nil;
@CbtfnLastError := nil;
end;
end;
end;
function HookError(errorCode: integer): string;
begin
if errorCode > 0 then
Result := SysErrorMessage(errorCode)
else if (errorCode >= Low(HookErrors)) and
(errorCode <= High(HookErrors)) then
Result := HookErrors[errorCode]
else
Result := Format('Error %d',[errorCode]);
end;
initialization
dllHandle := 0;
dllCount := 0;
CbtfnAttachReceiver := nil;
CbtfnDetachReceiver := nil;
CbtfnLastError := nil;
finalization
if dllHandle <> 0 then
MessageBox(0, 'CBT Hook DLL was not unloaded!', 'CBTHOOK', MB_OK + MB_ICONWARNING);
end.
Commenti
Posta un commento