paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-20 10:59:07 +02:00
Code Issues Packages Projects Releases Wiki Activity

Added code for TApplication to get it ready to accept exceptions.

Browse Source 
Shane

git-svn-id: trunk@378 -
This commit is contained in:
lazarus 2001-10-31 21:43:29 +00:00
parent 0b9d70ec39
commit bb9b3d32fe
5 changed files with 32 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
designer/controlselection.pp
View File

@ -29,7 +29,7 @@ uses
type type
GenException = class(Exception); EGenException = class(Exception);
TGrabberMoveEvent = procedure(Sender: TObject; dx, dy: Integer) of object; TGrabberMoveEvent = procedure(Sender: TObject; dx, dy: Integer) of object;
@ -440,14 +440,15 @@ end;
procedure TControlSelection.EndUpdate; procedure TControlSelection.EndUpdate;
begin begin
if FUpdateLock<=0 then exit; if FUpdateLock<=0 then exit;
Writeln('1');
dec(FUpdateLock); dec(FUpdateLock);
if FUpdateLock=0 then if FUpdateLock=0 then
begin begin
try try
if FChangedDuringLock then DoChange; if FChangedDuringLock then DoChange;
except except
raise GenException.Create('Exception Occured'); raise EGenException.Create('Exception Occured in ControlSelection EndUpdate');
end; end;
end; end;
end; end;
@ -543,8 +544,7 @@ try
FChangedDuringLock:=false; FChangedDuringLock:=false;
end; end;
except except
Writeln('Exception in DoChange'); raise EGenException.Create('Exception Occured in ControlSelection DoChange');
//Crashes!!!! raise GenException.Create('Exception Occured');
end; end;
end; end;

5
designer/objectinspector.pp
View File

@ -33,6 +33,9 @@ uses
Dialogs; Dialogs;
type type
EGenException = class(Exception);
TObjectInspector = class; TObjectInspector = class;
TOIOptions = class TOIOptions = class
@ -1506,7 +1509,7 @@ Try
Result:=c.GetNamePath+': '+c.ClassName; Result:=c.GetNamePath+': '+c.ClassName;
except except
Result := ''; Result := '';
Writeln('Exception: ObjectInspector ComponentToString'); Raise EGEnException.Create('Exception in ObjectInspector ComponentToString');
end; end;
end; end;

5
lcl/forms.pp
View File

@ -27,6 +27,7 @@
unit Forms; unit Forms;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
@ -256,6 +257,8 @@ type
procedure Idle; procedure Idle;
procedure MouseIdle(const CurrentControl: TControl); procedure MouseIdle(const CurrentControl: TControl);
procedure SetIcon(AValue: TIcon); procedure SetIcon(AValue: TIcon);
procedure ExceptionOccurred(Sender : TObject; Addr,Frame : Pointer);
public public
constructor Create(AOwner: TComponent); override; constructor Create(AOwner: TComponent); override;
destructor Destroy; override; destructor Destroy; override;
@ -307,7 +310,7 @@ function InitResourceComponent(Instance: TComponent; RootAncestor: TClass):Boole
var var
Application : TApplication; Application : TApplication;
Screen : TScreen; Screen : TScreen;
ExceptionObject : TExceptObject;
implementation implementation

14
lcl/include/application.inc
View File

@ -16,6 +16,7 @@ begin
FIcon := nil; FIcon := nil;
inherited Create(AOwner); inherited Create(AOwner);
// RaiseProc := @ExceptionOccurred;
end; end;
{------------------------------------------------------------------------------} {------------------------------------------------------------------------------}
@ -297,9 +298,22 @@ begin
end; end;
end; end;
procedure TApplication.ExceptionOccurred(Sender : TObject; Addr,Frame : Pointer);
var
Mess : String;
Begin
Mess := 'Error occurred at '#13#10'Address '+inttostr(longint(addr));
MessageBox('Exception',pchar(Mess),mb_IconError+mb_Ok);
end;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.9 2001/10/31 21:43:29 lazarus
Added code for TApplication to get it ready to accept exceptions.
Shane
Revision 1.8 2001/10/15 13:11:28 lazarus Revision 1.8 2001/10/15 13:11:28 lazarus
MG: added complete code MG: added complete code

5
lcl/lcllinux.pp
View File

@ -414,6 +414,7 @@ MB_ABORTRETRYIGNORE = $00000002;
MB_YESNOCANCEL = $00000003; MB_YESNOCANCEL = $00000003;
MB_YESNO = $00000004; MB_YESNO = $00000004;
MB_RETRYCANCEL = $00000005; MB_RETRYCANCEL = $00000005;
MB_ICONERROR = $00000010;
IDOK = 1; ID_OK = IDOK; IDOK = 1; ID_OK = IDOK;
IDCANCEL = 2; ID_CANCEL = IDCANCEL; IDCANCEL = 2; ID_CANCEL = IDCANCEL;
@ -1387,6 +1388,10 @@ end.
{ {
$Log$ $Log$
Revision 1.11 2001/10/31 21:43:28 lazarus
Added code for TApplication to get it ready to accept exceptions.
Shane
Revision 1.10 2001/09/30 08:34:49 lazarus Revision 1.10 2001/09/30 08:34:49 lazarus
MG: fixed mem leaks and fixed range check errors MG: fixed mem leaks and fixed range check errors