paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-17 08:09:26 +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
GenException = class(Exception);
EGenException = class(Exception);
TGrabberMoveEvent = procedure(Sender: TObject; dx, dy: Integer) of object;
@ -440,14 +440,15 @@ end;
procedure TControlSelection.EndUpdate;
begin
if FUpdateLock<=0 then exit;
Writeln('1');
dec(FUpdateLock);
if FUpdateLock=0 then
begin
try
if FChangedDuringLock then DoChange;
except
raise GenException.Create('Exception Occured');
raise EGenException.Create('Exception Occured in ControlSelection EndUpdate');
end;
end;
end;
@ -543,8 +544,7 @@ try
FChangedDuringLock:=false;
end;
except
Writeln('Exception in DoChange');
//Crashes!!!! raise GenException.Create('Exception Occured');
raise EGenException.Create('Exception Occured in ControlSelection DoChange');
end;
end;

5
designer/objectinspector.pp
View File

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

5
lcl/forms.pp
View File

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

14
lcl/include/application.inc
View File

@ -16,6 +16,7 @@ begin
FIcon := nil;
inherited Create(AOwner);
// RaiseProc := @ExceptionOccurred;
end;
{------------------------------------------------------------------------------}
@ -297,9 +298,22 @@ begin
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$
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
MG: added complete code

5
lcl/lcllinux.pp
View File

@ -414,6 +414,7 @@ MB_ABORTRETRYIGNORE = $00000002;
MB_YESNOCANCEL = $00000003;
MB_YESNO = $00000004;
MB_RETRYCANCEL = $00000005;
MB_ICONERROR = $00000010;
IDOK = 1; ID_OK = IDOK;
IDCANCEL = 2; ID_CANCEL = IDCANCEL;
@ -1387,6 +1388,10 @@ end.
{
$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
MG: fixed mem leaks and fixed range check errors