paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-01 21:20:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

Introduces the define DEBUG_ALLOW_DUMPBACKTRACE which removes code to dump a backtrace to the console, which crashes WinCE applications. Fixed bug #15075

Browse Source 
git-svn-id: trunk@22722 -
This commit is contained in:
sekelsenmat 2009-11-23 13:51:52 +00:00
parent c91bb602d6
commit 2774606c92
4 changed files with 12 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
lcl/forms.pp
View File

@ -1584,6 +1584,7 @@ Begin
DebugLn('[FORMS.PP] ExceptionOccurred '); DebugLn('[FORMS.PP] ExceptionOccurred ');
if HaltingProgram or HandlingException then Halt; if HaltingProgram or HandlingException then Halt;
HandlingException:=true; HandlingException:=true;
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
if Sender<>nil then begin if Sender<>nil then begin
DebugLn(' Sender=',Sender.ClassName); DebugLn(' Sender=',Sender.ClassName);
if Sender is Exception then begin if Sender is Exception then begin
@ -1595,6 +1596,7 @@ Begin
end; end;
end else end else
DebugLn(' Sender=nil'); DebugLn(' Sender=nil');
{$endif}
if Application<>nil then if Application<>nil then
Application.HandleException(Sender); Application.HandleException(Sender);
HandlingException:=false; HandlingException:=false;

4
lcl/include/application.inc
View File

@ -1073,7 +1073,9 @@ begin
DebugLn('TApplication.HandleException: ', DebugLn('TApplication.HandleException: ',
'there was another exception during showing the first exception'); 'there was another exception during showing the first exception');
HaltingProgram:=true; HaltingProgram:=true;
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
DumpExceptionBackTrace; DumpExceptionBackTrace;
{$endif}
Halt; Halt;
end; end;
Include(FFlags,AppHandlingException); Include(FFlags,AppHandlingException);
@ -1083,6 +1085,7 @@ begin
Skip := ExceptObject is EAbort; Skip := ExceptObject is EAbort;
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
if not (AppNoExceptionMessages in FFlags) then if not (AppNoExceptionMessages in FFlags) then
begin begin
// before we do anything, write it down // before we do anything, write it down
@ -1099,6 +1102,7 @@ begin
DumpExceptionBackTrace; DumpExceptionBackTrace;
end; end;
end; end;
{$endif}
// release capture and hide all forms with stay on top, so that // release capture and hide all forms with stay on top, so that
// a message can be shown // a message can be shown
if GetCapture <> 0 then SendMessage(GetCapture, LM_CANCELMODE, 0, 0); if GetCapture <> 0 then SendMessage(GetCapture, LM_CANCELMODE, 0, 0);

4
lcl/lclproc.pas
View File

@ -183,7 +183,9 @@ function StrToDouble(const s: string): double;
// debugging // debugging
procedure RaiseGDBException(const Msg: string); procedure RaiseGDBException(const Msg: string);
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
procedure DumpExceptionBackTrace; procedure DumpExceptionBackTrace;
{$endif}
procedure DumpStack; procedure DumpStack;
function GetStackTrace(UseCache: boolean): string; function GetStackTrace(UseCache: boolean): string;
procedure GetStackTracePointers(var AStack: TStackTracePointers); procedure GetStackTracePointers(var AStack: TStackTracePointers);
@ -1504,6 +1506,7 @@ begin
if (length(Msg) div (length(Msg) div 10000))=0 then ; if (length(Msg) div (length(Msg) div 10000))=0 then ;
end; end;
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
procedure DumpExceptionBackTrace; procedure DumpExceptionBackTrace;
var var
FrameCount: integer; FrameCount: integer;
@ -1517,6 +1520,7 @@ begin
for FrameNumber := 0 to FrameCount-1 do for FrameNumber := 0 to FrameCount-1 do
DebugLn(BackTraceStrFunc(Frames[FrameNumber])); DebugLn(BackTraceStrFunc(Frames[FrameNumber]));
end; end;
{$endif}
procedure DumpStack; procedure DumpStack;
begin begin

2
lcl/translations.pas
View File

@ -404,11 +404,13 @@ begin
{$endif ver2_0} {$endif ver2_0}
Result:=true; Result:=true;
except except
{$ifdef DEBUG_ALLOW_DUMPBACKTRACE}
on e: Exception do begin on e: Exception do begin
DebugLn('Exception while translating ', ResUnitName); DebugLn('Exception while translating ', ResUnitName);
DebugLn(e.Message); DebugLn(e.Message);
DumpExceptionBackTrace; DumpExceptionBackTrace;
end; end;
{$endif}
end; end;
end; end;