Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "Прочее";
Текущий архив: 2013.03.22;
Скачать: [xml.tar.bz2];

Вниз

Перехватить любой Exception и подменить текст   Найти похожие ветки 

 
DevilDevil ©   (2012-11-25 02:55) [0]

Стоит у меня задача детализировать ошибку. Откуда я буду брать информацию для детализации - дело моё. Меня интересует в теории как можно перехватить возникновения Exception-а и подменить текст. Причём чтобы и из-под IDE текст подменился, вне IDE. Хотя бы в Windows

Стал копать. Набрёл на функцию RaiseExceptionProc, находящуюся в модуле System. В целом это указатель на виндусовую функцию RaiseException. Но можно временно подменить указатель на мою функцию с перевызовом системной функции.

Ok. Пол дела сделано. Остаётся вопрос:
как подменить текст ошибки ?
т.е. где он хранится.

этот метод отмёл, потому что из-под IDE будет вызываться двойной Exception, вместо одинарного
try

except
 on E: Exception do
 begin
   // bla-bla
   raise {bla-bla};
 end;
end;


 
DevilDevil ©   (2012-11-25 02:56) [1]

*Причём чтобы и из-под IDE текст подменился, и вне IDE (показывался пользователю в красном окне)


 
Дмитрий С ©   (2012-11-25 03:07) [2]

поправь реализацию Exception  и перекомпилируй генофонд:)


 
DevilDevil ©   (2012-11-25 03:10) [3]

> Дмитрий С ©   (25.11.12 03:07) [2]

идея... но не прокатит в моём случае


 
брат Птибурдукова   (2012-11-25 10:33) [4]

unit System;
...
ExceptProc: Pointer;    { Unhandled exception handler }
 ErrorProc: procedure (ErrorCode: Byte; ErrorAddr: Pointer);     { Error handler procedure }
{$IFDEF MSWINDOWS}
 ExceptClsProc: Pointer; { Map an OS Exception to a Delphi class reference }
 ExceptObjProc: Pointer; { Map an OS Exception to a Delphi class instance }
{$IF defined(CPU386)}
 RaiseExceptionProc: Pointer;
{$ELSE}
 RaiseExceptionProc: TRaiseExceptionProc;
{$IFEND}
 RTLUnwindProc: Pointer;
{$ENDIF MSWINDOWS}
 RaiseExceptObjProc: Pointer; { notify of the raise of an exception object }
 ExceptionAcquired: Pointer; { notification that a given exception object has been "acquired" (C++)}
 ExceptionClass: TClass; { Exception base class (must be Exception) }
 SafeCallErrorProc: TSafeCallErrorProc; { Safecall error handler }
 AssertErrorProc: TAssertErrorProc; { Assertion error handler }
 ExitProcessProc: procedure; { Hook to be called just before the process actually exits }
 AbstractErrorProc: procedure; { Abstract method error handler }

Попробуй поколупаться тут.


> вне IDE (показывался пользователю в красном окне)
Попробуй TApplicationEvents.OnException


 
DevilDevil ©   (2012-11-25 13:51) [5]

> брат Птибурдукова   (25.11.12 10:33) [4]

если вызвать Raise Exception.Create("") будет перевызов _RaiseException
и в нём никаких полей не заполняется, только вызов RaiseExceptionProc, о которой я говорил


 
DevilDevil ©   (2012-11-25 14:02) [6]

*_RaiseExcept


 
Дмитрий С ©   (2012-11-25 19:19) [7]

Решил придумать извращенный способ, в итоге придумал нормальный:

var
 LastRaiseObjProc: Pointer;

procedure EP(Obj: PExceptionRecord);
begin
 Exception(Obj.ExceptObject).Message := Exception(Obj.ExceptObject).Message + ":)";
 TRaiseExceptObjProc(LastRaiseObjProc)(Obj);
end;

// test
begin
 LastRaiseObjProc := RaiseExceptObjProc;
 RaiseExceptObjProc := @EP;
 raise Exception.Create("qwe");
end;


 
Дмитрий С ©   (2012-11-25 21:30) [8]

Хотя это немного не то.

Взять, например код
I:=0;
I:=1/I;

Ставим бряк на все Exception.Create(...);

Запускаем. И видим, что сначала происходит отображение ошибки среды, а потом, только после Continue - создается Exception для его raising-а. Следовательно, поправить текст для среды ты никак не сможешь.


 
DevilDevil ©   (2012-11-26 00:53) [9]

> Следовательно, поправить текст для среды ты никак не сможешь.

я думаю экземпляр Exception можно перехватить в RaiseExceptionProc
только я ещё не понял, как


 
Германн ©   (2012-11-26 02:14) [10]


> Причём чтобы и из-под IDE текст подменился

А вот для чего разумного такое надо?
Отладчик по определению должен возвращать истинные значения чего бы там ни было! Иначе это не отладчик, а злодей.


 
baks   (2012-11-26 09:50) [11]

> А вот для чего разумного такое надо?

Я думаю, что это не для разумного. Данная функция даст возможность запутать пользователя показав неправильную информацию об ошибке.

> Откуда я буду брать информацию - дело мое

:)


 
DevilDevil ©   (2012-11-26 10:17) [12]

> Германн ©   (26.11.12 02:14) [10]

я уже сказал в [0]
надо детализировать ошибку. прибавить к тексту дополнительную информацию


 
брат Птибурдукова   (2012-11-26 10:23) [13]


> Данная функция даст возможность запутать пользователя показав
> неправильную информацию об ошибке.
Пользователю и без танцев с бубном можно выдать всё, чего пожелается.


 
Baks   (2012-11-26 10:59) [14]


> Пользователю и без танцев с бубном можно выдать всё, чего
> пожелается.


Нет, не просто выдать, а подменить сообщение об ошибке.


 
Rouse_ ©   (2012-11-26 11:52) [15]

Для подмены можно сделать вот такой класс:

unit uRaiseExceptionHook;

interface

uses
 Windows,
 SysUtils;

type
 TExceptionEvent = procedure (Sender: TObject; E: Exception) of object;
 TRaiseExceptObject = procedure(P: PExceptionRecord);

 TRaiseExceptionHook = class
 private
   FRaiseExceptObjProc: TRaiseExceptObject;
   FActive: Boolean;
   FBeforeException: TExceptionEvent;
 protected
   procedure DoBeforeException(P: PExceptionRecord);
 public
   constructor Create;
   destructor Destroy; override;
   procedure SetHook(Active: Boolean);
   property OnBeforeException: TExceptionEvent read FBeforeException
     write FBeforeException;
 end;

 function RaiseExceptionHook: TRaiseExceptionHook;

implementation

var
 _RaiseExceptionHook: TRaiseExceptionHook = nil;

function RaiseExceptionHook: TRaiseExceptionHook;
begin
 if _RaiseExceptionHook = nil then
   _RaiseExceptionHook := TRaiseExceptionHook.Create;
 Result := _RaiseExceptionHook;
end;

procedure RaiseExceptObject(P: PExceptionRecord);
begin
 RaiseExceptionHook.DoBeforeException(P);
end;

{ TRaiseExceptionHook }

constructor TRaiseExceptionHook.Create;
begin
 FRaiseExceptObjProc := RaiseExceptObjProc;
end;

destructor TRaiseExceptionHook.Destroy;
begin
 SetHook(False);
 inherited;
end;

procedure TRaiseExceptionHook.DoBeforeException(P: PExceptionRecord);
begin
 if TObject(P.ExceptObject) is Exception then
   if Assigned(FBeforeException) then
     FBeforeException(Self, TObject(P.ExceptObject) as Exception);
 FRaiseExceptObjProc(P);
end;

procedure TRaiseExceptionHook.SetHook(Active: Boolean);
begin
 if FActive = Active then Exit;
 FActive := Active;
 if Active then
   RaiseExceptObjProc := @RaiseExceptObject
 else
   RaiseExceptObjProc := @FRaiseExceptObjProc;
end;

end.


ну и соответственно использование:

type
 EMyException = class(Exception);

procedure TForm1.OnBeforeException(Sender: TObject; E: Exception);
begin
 E.Message := E.Message + sLineBreak + "2";
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 RaiseExceptionHook.OnBeforeException := OnBeforeException;
 RaiseExceptionHook.SetHook(True);
 raise EMyException.Create("1");
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
 RaiseExceptionHook.SetHook(False);
 raise EMyException.Create("1");
end;


 
DevilDevil ©   (2012-11-26 12:25) [16]

> Rouse_ ©   (26.11.12 11:52) [15]

круто, спасибо
я тестирую в Delphi6 и Delphi7
но там нет обработчика RaiseExceptObjProc


 
DevilDevil ©   (2012-11-26 12:26) [17]

Попробуйте пожалуйста у себя такой код:

{$ifdef MSWINDOWS}
var
 SYS_EXCEPTION_PROC: Pointer;

procedure ExceptionRecaller(const E: Exception);
begin
 E.Message := E.Message + #13#13"My Text!";
end;

procedure __ExceptionRecaller;
const
 cDelphiException    = $0EEDFADE;
 cNonDelphiException = $0EEDFAE4;
 SysUtilsException: TClass = SysUtils.Exception;
asm
 cmp [esp+4], cDelphiException
 je @check_exception
 cmp [esp+4], cNonDelphiException
 je @check_exception
jmp @run_default
@check_exception:
 mov eax, [esp+24]
 mov edx, SysUtilsException
 mov eax, [eax]
 call TObject.InheritsFrom
 and eax, $ff
 jz @run_default

 mov eax, [esp+24]
 call ExceptionRecaller

@run_default:
 jmp SYS_EXCEPTION_PROC
end;

procedure InitExceptionsRoutine();
begin
 SYS_EXCEPTION_PROC := System.RaiseExceptionProc;
 System.RaiseExceptionProc := @__ExceptionRecaller; {test}
end;
{$else}
procedure InitExceptionsRoutine();
begin
 // todo ?
end;
{$endif}

procedure TForm1.Button1Click(Sender: TObject);
begin
//  PPoint(nil).X := 0;

 raise Exception.Create("dsadasd");
end;

initialization
 InitExceptionsRoutine();


 
Дмитрий С ©   (2012-11-26 12:34) [18]


> Rouse_ ©   (26.11.12 11:52) [15]

Этот код не всегда сработает. Он работает только для оператора raise.
Для кода
I:=0;I:=1/I; текст он не подменит.


 
Rouse_ ©   (2012-11-26 12:56) [19]


> Он работает только для оператора raise.

Ну это уже особенности реализации NotifyNonDelphiException.


 
DevilDevil ©   (2012-11-26 13:05) [20]

Сварганил я такой код
проверьте пожалуйста
и в IDE, и вне IDE

procedure CopyObject(const Dest, Src: TObject); forward;

{$ifdef MSWINDOWS}
var
 SYS_EXCEPTION_PROC: Pointer;

procedure ExceptionHandler(const E: Exception);
begin
 E.Message := E.Message + #13#13"My Text!";
end;

procedure __ExceptionRecaller;
const
 cDelphiException    = $0EEDFADE;
 cNonDelphiException = $0EEDFAE4;
 SysUtilsException: TClass = SysUtils.Exception;
asm
 cmp [esp+4], cDelphiException
 je @check_exception
 cmp [esp+4], cNonDelphiException
 je @check_exception
jmp @run_default
@check_exception:
 mov eax, [esp+24]
 mov edx, SysUtilsException
 mov eax, [eax]
 call TObject.InheritsFrom
 and eax, $ff
 jz @run_default

 mov eax, [esp+24]
 call ExceptionHandler

@run_default:
 mov eax, SYS_EXCEPTION_PROC
 mov System.RaiseExceptionProc, eax
 jmp eax
end;
{$else}
 // todo ?
{$endif}

// çàïóñòèòü êàêóþ-òî ïðîöåäóðó ñ ïåðåõâàòîì Exception-à
procedure RunCode(const Proc: TProcedure);
var
 NewException: Exception;
begin
 if (System.DebugHook > 0) then
 begin
   try
     System.RaiseExceptionProc := @__ExceptionRecaller;
     Proc();
   finally
     System.RaiseExceptionProc := SYS_EXCEPTION_PROC;
   end;
 end else
 begin
   try
     Proc();
   except
     on E: Exception do
     begin
       NewException := Exception(E.ClassType.NewInstance());
       CopyObject(NewException, E);
       ExceptionHandler(NewException);
       raise NewException;
     end;
   end;
 end;
end;

procedure DoBad_1();
begin
 PPoint(nil).X := 0;
end;

procedure DoBad_2();
begin
 raise Exception.Create("dsadasd");
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
 RunCode(@DoBad_1);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
 RunCode(@DoBad_2);
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
 if (Key = VK_ESCAPE) then Close;
end;

{$ifdef fpc}
Function fpc_Copy_internal (Src, Dest, TypeInfo : Pointer) : SizeInt;[external name "FPC_COPY"];
procedure CopyRecord(const dest, source, typeinfo: ptypeinfo);
asm
 {âíèìàíèå! î÷åíü ïëîõî ðàáîòàåò â FPC !!!}
 xchg eax, edx
 jmp fpc_Copy_internal
end;
{$else}
procedure CopyRecord(const dest, source, typeinfo: ptypeinfo);
asm
 jmp System.@CopyRecord
end;
{$endif}

procedure CopyObject(const Dest, Src: TObject);
var
 InitTable: pointer;
 BaseSize, DestSize: integer;
 BaseClass, DestClass, SrcClass: TClass;
begin
 if (Dest = nil) or (Src = nil) then exit; {ïî èäåå ýêñåïøí}

 DestClass := TClass(pointer(Dest)^);
 SrcClass := TClass(pointer(Src)^);

 if (DestClass = SrcClass) then BaseClass := DestClass
 else
 if (DestClass.InheritsFrom(SrcClass)) then BaseClass := SrcClass
 else
 if (SrcClass.InheritsFrom(DestClass)) then BaseClass := DestClass
 else
 begin
   BaseClass := DestClass;

   while (BaseClass <> nil) and (not SrcClass.InheritsFrom(BaseClass)) do
   begin
     BaseClass := BaseClass.ClassParent;
   end;

   if (BaseClass = nil) then exit; {&#237;&#238; &#242;&#224;&#234;&#238;&#227;&#238; &#237;&#229; &#228;&#238;&#235;&#230;&#237;&#238; &#225;&#251;&#242;&#252;}
 end;

 // &#234;&#238;&#239;&#232;&#240;&#238;&#226;&#224;&#237;&#232;&#229;
 DestSize := BaseClass.InstanceSize;
 while (BaseClass <> TObject) do
 begin
   InitTable := PPointer(Integer(BaseClass) + vmtInitTable)^;
   if (InitTable <> nil) then
   begin
     CopyRecord(pointer(Dest), pointer(Src), InitTable);
     break;
   end;
   BaseClass := BaseClass.ClassParent;
 end;

 BaseSize := BaseClass.InstanceSize;
 if (BaseSize <> DestSize) then Move(pointer(integer(Src)+BaseSize)^, pointer(integer(Dest)+BaseSize)^, DestSize-BaseSize);
end;

initialization
 {$ifdef MSWINDOWS}
    SYS_EXCEPTION_PROC := System.RaiseExceptionProc;
 {$endif}


 
Разведка   (2012-11-26 20:47) [21]

interface

Uses Windows;

function SystemErrorMessage(ErrorCode: Integer): string;
function GetSysErrorMessage(ErrorCode: Integer): String;
procedure SaveErrorMessage(DebugMsg: String);

var
 LAST_ERROR_MESSAGE : String;

implementation

procedure SaveErrorMessage(DebugMsg: String);
begin
 if DebugMsg <> "" then
   LAST_ERROR_MESSAGE := DebugMsg+" "+GetSysErrorMessage(GetLastError)
 else LAST_ERROR_MESSAGE := GetSysErrorMessage(GetLastError)
end;

{------------------------- GetSysErrorMessage ---------------------------------}
function GetSysErrorMessage(ErrorCode: Integer): String;
Var s: string;
begin
 Str(ErrorCode:0,S);
 Result:="System Error. Code: "+s+" "+SystemErrorMessage(ErrorCode)+".";
end;

{------------------------- SystemErrorMessage ---------------------------------}
function SystemErrorMessage(ErrorCode: Integer): string;
var
 Buffer : array[0..255] of Char;
 Len    : Integer;
begin
 Len := FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or
                      FORMAT_MESSAGE_ARGUMENT_ARRAY, nil, ErrorCode, 0, Buffer,
                      SizeOf(Buffer), nil);
 while (Len > 0) and (Buffer[Len - 1] in [ #0..#32, "."]) do Dec(Len);
 SetString(Result, Buffer, Len);
end;
end.


Использую так:

Uses Error;
  //.......
try
 //код программы
except
  если нужно тихой цапой слить сообщение в другое окошко
  то делаем так
 
 memo1.lines.add(GetSysErrorMessage(getlasterror)) ;
 это оналог RaiseLastWin32Error,
 
end;


 
DevilDevil ©   (2012-11-26 20:56) [22]

> Разведка   (26.11.12 20:47) [21]

не подходит по условиям задачи


 
Rouse_ ©   (2012-11-26 21:49) [23]


> DevilDevil ©   (26.11.12 20:56) [22]

Ты кстати похоже очень вовремя появился со своим вопросом. Тут откуда не возьмись вылезла задача именно такого-же плана по работе :)
Как сглазил блин :)
Возьму твой вариант за основу и завтра более плотно потестирую на своей нагрузке, если что вылезет (хотя судя по коду не должно, на вскидку) сообщу.


 
DevilDevil ©   (2012-11-26 23:11) [24]

> Rouse_ ©   (26.11.12 21:49) [23]

:)
а я эту задачу обверну завтра более сложными наворотами :)

кстати если узнаешь как реализовать под другие ОС кроме Windows - говори )



Страницы: 1 вся ветка

Форум: "Прочее";
Текущий архив: 2013.03.22;
Скачать: [xml.tar.bz2];

Наверх




Память: 0.53 MB
Время: 0.069 c
2-1343746048
jacksotnik
2012-07-31 18:47
2013.03.22
In в фильтре


15-1331246578
Дмитрий С
2012-03-09 02:42
2013.03.22
FreePascal под линуксом.


15-1350554228
ProgRAMmer Dimonych
2012-10-18 13:57
2013.03.22
Помогите с SQL-запросом


2-1329298711
ixen
2012-02-15 13:38
2013.03.22
Вопросы по потокам


2-1335703270
Vik
2012-04-29 16:41
2013.03.22
Создание текстовых файлов последовательно.





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский