Если dll чужая - трудно что-то сделать, но если вы её делаете сами (модульная структура у вашей программы, например) - то решение, которое я нашёл - 100% для вас. Зверь повержен!
Вкратце: устанавливаем собственный хандлер исключений. В нём проверяем адрес исключения: если он не принадлежит искомой dll, то вызываем старый хандлер (который установила RTL при старте программы). Если принадлежит - подтасовываем адрес возврата на процедуру, которая вызовет специальную процедуру вашей dll, вызывающую языковое исключение. Которое затем отлично ловится всеми блоками try!
Всё на буржуинском, поскольку хочу ещё на форум pascalgamedevelopment запостить.
Если хотите более внятных сообщений об ошибках - организуйте в собственном хандлере механизм записи информации об исключении (хотя бы кода исключения) в глобальную переменную и затем передавайте исключениевызывающей функции dll, чтобы та уже сочиняла более подробные сообщения об ошибках.
Хак проверен на практике под Windows XP и под Wine, полёт нормальный.
(P.S. Это FreePascal 2.2.x)
sehhck_dll.pas:
- Код: Выделить всё
library sehhck_dll;
{$mode objfpc}
{$longstrings on}
uses
Classes, SysUtils, Windows;
procedure mytestproc; cdecl; export;
begin
try
WriteLn('Now DLL will raise an Access Violation...');
byte(nil^):= 0;
except
WriteLn('DLL caught an exception:');
WriteLn(' "' + (ExceptObject as Exception).Message
+ '" of ' + (ExceptObject as Exception).ClassName);
end;
end;
procedure myraiseproc; cdecl; export;
begin
WriteLn('Now DLL will raise a Pascal exception...');
Raise Exception.Create('Manually raised Pascal exception');
end;
exports
mytestproc name 'mytestproc',
myraiseproc name 'myraiseproc';
end.
sehhck_exe.pas:
- Код: Выделить всё
program sehhk_exe;
{$mode delphi}
{$longstrings on}
{$apptype console}
uses
Classes, SysUtils, Windows;
//Copy-pasted from the System unit --------------------------------------------\
{
Error code definitions for the Win32 API functions
Values are 32 bit values layed out as follows:
3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1
1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
+---+-+-+-----------------------+-------------------------------+
|Sev|C|R| Facility | Code |
+---+-+-+-----------------------+-------------------------------+
where
Sev - is the severity code
00 - Success
01 - Informational
10 - Warning
11 - Error
C - is the Customer code flag
R - is a reserved bit
Facility - is the facility code
Code - is the facility's status code
}
const
SEVERITY_SUCCESS = $00000000;
SEVERITY_INFORMATIONAL = $40000000;
SEVERITY_WARNING = $80000000;
SEVERITY_ERROR = $C0000000;
const
STATUS_SEGMENT_NOTIFICATION = $40000005;
DBG_TERMINATE_THREAD = $40010003;
DBG_TERMINATE_PROCESS = $40010004;
DBG_CONTROL_C = $40010005;
DBG_CONTROL_BREAK = $40010008;
STATUS_GUARD_PAGE_VIOLATION = $80000001;
STATUS_DATATYPE_MISALIGNMENT = $80000002;
STATUS_BREAKPOINT = $80000003;
STATUS_SINGLE_STEP = $80000004;
DBG_EXCEPTION_NOT_HANDLED = $80010001;
STATUS_ACCESS_VIOLATION = $C0000005;
STATUS_IN_PAGE_ERROR = $C0000006;
STATUS_INVALID_HANDLE = $C0000008;
STATUS_NO_MEMORY = $C0000017;
STATUS_ILLEGAL_INSTRUCTION = $C000001D;
STATUS_NONCONTINUABLE_EXCEPTION = $C0000025;
STATUS_INVALID_DISPOSITION = $C0000026;
STATUS_ARRAY_BOUNDS_EXCEEDED = $C000008C;
STATUS_FLOAT_DENORMAL_OPERAND = $C000008D;
STATUS_FLOAT_DIVIDE_BY_ZERO = $C000008E;
STATUS_FLOAT_INEXACT_RESULT = $C000008F;
STATUS_FLOAT_INVALID_OPERATION = $C0000090;
STATUS_FLOAT_OVERFLOW = $C0000091;
STATUS_FLOAT_STACK_CHECK = $C0000092;
STATUS_FLOAT_UNDERFLOW = $C0000093;
STATUS_INTEGER_DIVIDE_BY_ZERO = $C0000094;
STATUS_INTEGER_OVERFLOW = $C0000095;
STATUS_PRIVILEGED_INSTRUCTION = $C0000096;
STATUS_STACK_OVERFLOW = $C00000FD;
STATUS_CONTROL_C_EXIT = $C000013A;
STATUS_FLOAT_MULTIPLE_FAULTS = $C00002B4;
STATUS_FLOAT_MULTIPLE_TRAPS = $C00002B5;
STATUS_REG_NAT_CONSUMPTION = $C00002C9;
EXCEPTION_EXECUTE_HANDLER = 1;
EXCEPTION_CONTINUE_EXECUTION = -1;
EXCEPTION_CONTINUE_SEARCH = 0;
EXCEPTION_MAXIMUM_PARAMETERS = 15;
CONTEXT_X86 = $00010000;
CONTEXT_CONTROL = CONTEXT_X86 or $00000001;
CONTEXT_INTEGER = CONTEXT_X86 or $00000002;
CONTEXT_SEGMENTS = CONTEXT_X86 or $00000004;
CONTEXT_FLOATING_POINT = CONTEXT_X86 or $00000008;
CONTEXT_DEBUG_REGISTERS = CONTEXT_X86 or $00000010;
CONTEXT_EXTENDED_REGISTERS = CONTEXT_X86 or $00000020;
CONTEXT_FULL= CONTEXT_CONTROL or CONTEXT_INTEGER or CONTEXT_SEGMENTS;
MAXIMUM_SUPPORTED_EXTENSION = 512;
type
PFloatingSaveArea = ^TFloatingSaveArea;
TFloatingSaveArea = packed record
ControlWord : Cardinal;
StatusWord : Cardinal;
TagWord : Cardinal;
ErrorOffset : Cardinal;
ErrorSelector : Cardinal;
DataOffset : Cardinal;
DataSelector : Cardinal;
RegisterArea : array[0..79] of Byte;
Cr0NpxState : Cardinal;
end;
PContext = ^TContext;
TContext = packed record
//
// The flags values within this flag control the contents of
// a CONTEXT record.
//
ContextFlags : Cardinal;
//
// This section is specified/returned if CONTEXT_DEBUG_REGISTERS is
// set in ContextFlags. Note that CONTEXT_DEBUG_REGISTERS is NOT
// included in CONTEXT_FULL.
//
Dr0, Dr1, Dr2,
Dr3, Dr6, Dr7 : Cardinal;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_FLOATING_POINT.
//
FloatSave : TFloatingSaveArea;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_SEGMENTS.
//
SegGs, SegFs,
SegEs, SegDs : Cardinal;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_INTEGER.
//
Edi, Esi, Ebx,
Edx, Ecx, Eax : Cardinal;
//
// This section is specified/returned if the
// ContextFlags word contains the flag CONTEXT_CONTROL.
//
Ebp : Cardinal;
Eip : Cardinal;
SegCs : Cardinal;
EFlags, Esp, SegSs : Cardinal;
//
// This section is specified/returned if the ContextFlags word
// contains the flag CONTEXT_EXTENDED_REGISTERS.
// The format and contexts are processor specific
//
ExtendedRegisters : array[0..MAXIMUM_SUPPORTED_EXTENSION-1] of Byte;
end;
type
PExceptionRecord = ^TExceptionRecord;
TExceptionRecord = packed record
ExceptionCode : cardinal;
ExceptionFlags : Longint;
ExceptionRecord : PExceptionRecord;
ExceptionAddress : Pointer;
NumberParameters : Longint;
ExceptionInformation : array[0..EXCEPTION_MAXIMUM_PARAMETERS-1] of Pointer;
end;
PExceptionPointers = ^TExceptionPointers;
TExceptionPointers = packed record
ExceptionRecord : PExceptionRecord;
ContextRecord : PContext;
end;
{ type of functions that should be used for exception handling }
TTopLevelExceptionFilter
= function (excep : PExceptionPointers) : Longint;stdcall;
function SetUnhandledExceptionFilter( lpTopLevelExceptionFilter:
TTopLevelExceptionFilter) : TTopLevelExceptionFilter;
stdcall;external 'kernel32' name 'SetUnhandledExceptionFilter';
//end copy-paste --------------------------------------------------------------/
var
Mydll: THandle = 0;
OldFilter: TTopLevelExceptionFilter = nil;
answer: string;
dllraiseproc: procedure; cdecl;
dlltestproc: procedure; cdecl;
procedure JumpToDllRaiseFunction;
begin
SysResetFPU;
dllraiseproc;
raise Exception.Create('Oops... Should''ve never reached this point!');
end;
function GetModuleByAddr(addr: pointer): THandle;
var
Tmm: TMemoryBasicInformation;
begin
if VirtualQuery(addr, @Tmm, SizeOf(Tmm)) <> sizeof(Tmm)
then Result:=0
else Result:= THandle(Tmm.AllocationBase);
end;
function MyExceptionFilter(excep : PExceptionPointers) : Longint; stdcall;
var
res: longint;
err: byte;
must_reset_fpu: boolean;
begin
WriteLn('System called our top level unhandled exception filter.'#10#13
+' Exception code = '
+ IntToHex(excep^.ExceptionRecord^.ExceptionCode, 8));
if MyDll = GetModuleByAddr(pointer(excep^.ContextRecord^.Eip)) then begin
WriteLn('The exception adress does belong to our DLL.');
excep^.ContextRecord^.Eip := Longint(@JumpToDllRaiseFunction);
excep^.ExceptionRecord^.ExceptionCode := 0;
Result := EXCEPTION_CONTINUE_EXECUTION;
end
else begin
WriteLn('The exception address doesn''t belong to our DLL.'#10#13
+' Calling the old filter installed by RTL.');
Result:= OldFilter(excep);
end;
end;
procedure InstallHack;
begin
OldFilter:= SetUnhandledExceptionFilter(MyExceptionFilter);
Writeln('Ensuring that the hack didn''t broke our own exception mechanism...');
try
WriteLn('Raising an AV...');
byte(nil^):= 0;
except
WriteLn('Exe caught an exception: '#10#13' "'
+ (ExceptObject as Exception).Message
+ '" by ' + (ExceptObject as Exception).ClassName);
end;
end;
begin
try
WriteLn('Loading the dll...');
MyDll:= LoadLibrary('./sehhck_dll.dll');
if MyDll = 0
then raise Exception.Create('Failed to load the dll! :(');
dllraiseproc:= GetProcAddress(MyDll, PChar('myraiseproc'));
dlltestproc:= GetProcAddress(MyDll, PChar('mytestproc'));
if not Assigned(@dlltestproc) or not Assigned(@dllraiseproc)
then raise Exception.Create('Failed to load procedures from the DLL');
WriteLn('Use the SEH hack? ("yes" / "no")') ;
answer:= '';
repeat
if answer <> '' then Writeln('Please enter "yes" or "no".');
readln(answer);
if answer = '' then Halt(0);
answer:= UpperCase(answer);
until (answer = 'YES') or (answer = 'NO');
if answer = 'YES' then InstallHack;
WriteLn('Testing!');
dlltestproc;
except
WriteLn('Exe caught an exception: '#10#13' "'
+ (ExceptObject as Exception).Message
+ '" by ' + (ExceptObject as Exception).ClassName);
end;
WriteLn('Press Enter to close.');
ReadLn;
end.
