mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-08-07 01:06:02 +02:00
added DumpExceptionBackTrace
git-svn-id: trunk@7263 -
This commit is contained in:
parent
25d8613949
commit
0c73a31caa
@ -817,19 +817,6 @@ end;
|
||||
------------------------------------------------------------------------------}
|
||||
procedure TApplication.HandleException(Sender: TObject);
|
||||
|
||||
procedure DumpStack;
|
||||
var
|
||||
FrameCount: integer;
|
||||
Frames: PPointer;
|
||||
FrameNumber:Integer;
|
||||
begin
|
||||
DebugLn(' Stack trace:');
|
||||
DebugLn(BackTraceStrFunc(ExceptAddr));
|
||||
FrameCount:=ExceptFrameCount;
|
||||
Frames:=ExceptFrames;
|
||||
for FrameNumber := 0 to FrameCount-1 do
|
||||
DebugLn(BackTraceStrFunc(Frames[FrameNumber]));
|
||||
end;
|
||||
begin
|
||||
if Self=nil then exit;
|
||||
if AppHandlingException in FFlags then begin
|
||||
@ -845,10 +832,10 @@ begin
|
||||
// before we do anything, write it down
|
||||
if ExceptObject is Exception then begin
|
||||
DebugLn('TApplication.HandleException ',Exception(ExceptObject).Message);
|
||||
DumpStack;
|
||||
end else begin
|
||||
DebugLn('TApplication.HandleException Strange Exception ');
|
||||
end;
|
||||
DumpExceptionBackTrace;
|
||||
// release capture and hide all forms with stay on top, so that
|
||||
// a message can be shown
|
||||
if GetCapture <> 0 then SendMessage(GetCapture, LM_CANCELMODE, 0, 0);
|
||||
@ -1488,6 +1475,9 @@ end;
|
||||
{ =============================================================================
|
||||
|
||||
$Log$
|
||||
Revision 1.124 2005/06/22 09:04:48 vincents
|
||||
added DumpExceptionBackTrace
|
||||
|
||||
Revision 1.123 2005/06/21 14:41:16 vincents
|
||||
- removed 1.x specific FindGlobalComponent
|
||||
- added writing stack trace of exception in Application.HandleException
|
||||
|
@ -29,7 +29,7 @@ unit LCLProc;
|
||||
interface
|
||||
|
||||
uses
|
||||
Classes, SysUtils, Math, LCLStrConsts, LCLType;
|
||||
Classes, SysUtils, Math, FPCAdds, LCLStrConsts, LCLType;
|
||||
|
||||
type
|
||||
{ TMethodList - array of TMethod }
|
||||
@ -109,6 +109,7 @@ function StrToDouble(const s: string): double;
|
||||
|
||||
// debugging
|
||||
procedure RaiseGDBException(const Msg: string);
|
||||
procedure DumpExceptionBackTrace;
|
||||
|
||||
procedure DebugLn(const S: String; Args: array of const);
|
||||
procedure DebugLn;
|
||||
@ -592,6 +593,20 @@ begin
|
||||
if (length(Msg) div (length(Msg) div 10000))=0 then ;
|
||||
end;
|
||||
|
||||
procedure DumpExceptionBackTrace;
|
||||
var
|
||||
FrameCount: integer;
|
||||
Frames: PPointer;
|
||||
FrameNumber:Integer;
|
||||
begin
|
||||
DebugLn(' Stack trace:');
|
||||
DebugLn(BackTraceStrFunc(ExceptAddr));
|
||||
FrameCount:=ExceptFrameCount;
|
||||
Frames:=ExceptFrames;
|
||||
for FrameNumber := 0 to FrameCount-1 do
|
||||
DebugLn(BackTraceStrFunc(Frames[FrameNumber]));
|
||||
end;
|
||||
|
||||
procedure MoveRect(var ARect: TRect; x, y: Integer);
|
||||
begin
|
||||
inc(ARect.Right,x-ARect.Left);
|
||||
|
Loading…
Reference in New Issue
Block a user