paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-04-09 19:08:03 +02:00
Code Issues Packages Projects Releases Wiki Activity

TApplication now uses ExitProc to free itself before all finaizations

Browse Source 
git-svn-id: trunk@6852 -
This commit is contained in:
mattias 2005-02-26 20:43:54 +00:00
parent 75695b098e
commit 5baf8a8fef
2 changed files with 24 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
lcl/forms.pp
View File

@ -890,8 +890,10 @@ type
FMouseControl: TControl;
FNavigation: TApplicationNavigationOptions;
FOldExceptProc: TExceptProc;
FOldExitProc: Pointer;
FOnActionExecute: TActionEvent;
FOnActionUpdate: TActionEvent;
FOnDestroy: TNotifyEvent;
FOnHelp: THelpEvent;
FOnHint: TNotifyEvent;
FOnIdle: TIdleEvent;
@ -1020,6 +1022,7 @@ type
property OnShortcut: TShortcutEvent read FOnShortcut write FOnShortcut;
property OnShowHint: TShowHintEvent read FOnShowHint write FOnShowHint;
property OnUserInput: TOnUserInputEvent read FOnUserInput write FOnUserInput;
property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy;
property ShowHint: Boolean read FShowHint write SetShowHint;
property Title: String read GetTitle write SetTitle;
end;
@ -1252,7 +1255,8 @@ end;
{$IFDEF ExceptionHasNoFrames}
procedure ExceptionOccurred(Sender: TObject; Addr,Frame: Pointer);
{$ELSE}
procedure ExceptionOccurred(Sender: TObject; Addr:Pointer; FrameCount:Longint; Frames: PPointer);
procedure ExceptionOccurred(Sender: TObject; Addr:Pointer; FrameCount: Longint;
Frames: PPointer);
var
FrameNumber: integer;
{$ENDIF}
@ -1277,6 +1281,12 @@ Begin
HandlingException:=false;
end;
procedure BeforeFinalization;
// This is our ExitProc handler.
begin
FreeInterfaceObject;
end;
//------------------------------------------------------------------------------
// The focus state is just the focus count for now. To save having to allocate
// anything, I just map the Integer to the TFocusState.
@ -1430,6 +1440,7 @@ end;
procedure FreeInterfaceObject;
begin
//debugln('FreeInterfaceObject');
if Application=nil then exit;
Application.Free;
Application:=nil;
FreeAllClipBoards;

12
lcl/include/application.inc
View File

@ -96,6 +96,8 @@ begin
inherited Create(AOwner);
CaptureExceptions:=true;
FOldExitProc:=ExitProc;
ExitProc:=@BeforeFinalization;
end;
{------------------------------------------------------------------------------
@ -105,7 +107,14 @@ destructor TApplication.Destroy;
var
HandlerType: TApplicationHandlerType;
begin
if Self=nil then
RaiseGDBException('TApplication.Destroy Self=nil');
Include(FFlags,AppDestroying);
if Assigned(FOnDestroy) then FOnDestroy(Self);
ExitProc:=FOldExitProc;
DoFreeReleaseComponents;
if OnMenuPopupHandler=@MenuPopupHandler then
OnMenuPopupHandler:=nil;
@ -1409,6 +1418,9 @@ end;
{ =============================================================================
$Log$
Revision 1.104 2005/02/26 20:43:54 mattias
TApplication now uses ExitProc to free itself before all finaizations
Revision 1.103 2005/02/26 20:26:03 mattias
fixed hint size and activate