From 151d72661ac29f70556346a8b29b239a495a1b7b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Micha=C3=ABl=20Van=20Canneyt?= <michael@freepascal.org>
Date: Sun, 15 Oct 2023 11:16:45 +0200
Subject: [PATCH] * Force close during destroy, add event to report errors

---
 packages/fcl-db/src/base/database.inc | 35 +++++++++++++++++++++++++--
 packages/fcl-db/src/base/db.pas       |  5 ++++
 packages/fcl-db/src/sqldb/sqldb.pp    |  2 +-
 3 files changed, 39 insertions(+), 3 deletions(-)

diff --git a/packages/fcl-db/src/base/database.inc b/packages/fcl-db/src/base/database.inc
index dc18552427..c07bed0e20 100644
--- a/packages/fcl-db/src/base/database.inc
+++ b/packages/fcl-db/src/base/database.inc
@@ -66,7 +66,7 @@ end;
 destructor TDatabase.Destroy;
 
 begin
-  Connected:=False;
+  CloseForDestroy;
   RemoveDatasets;
   RemoveTransactions;
   FDatasets.Free;
@@ -650,6 +650,12 @@ begin
   FBeforeDisconnect:=AValue;
 end;
 
+procedure TCustomConnection.DoCloseError(aError: Exception);
+begin
+  if Assigned(FOnCloseError) then
+    FOnCloseError(Self,aError);
+end;
+
 procedure TCustomConnection.DoLoginPrompt;
 
 var
@@ -764,9 +770,34 @@ begin
   end;
 end;
 
+procedure TCustomConnection.CloseForDestroy;
+
+Const
+  MaxCount = 2;
+
+var
+  Force : Boolean;
+  aCount : Integer;
+begin
+  Force:=False;
+  aCount:=0;
+  While Connected and (aCount<MaxCount) do
+    try
+      Inc(aCount);
+      // Will set connected to false
+      Close(Force);
+    except
+      On E : Exception do
+        begin
+        Force:=True;
+        DoCloseError(E);
+        end;
+    end;
+end;
+
 destructor TCustomConnection.Destroy;
 begin
-  Connected:=False;
+  CloseForDestroy;
   Inherited Destroy;
 end;
 
diff --git a/packages/fcl-db/src/base/db.pas b/packages/fcl-db/src/base/db.pas
index ec484c9973..949db4ab65 100644
--- a/packages/fcl-db/src/base/db.pas
+++ b/packages/fcl-db/src/base/db.pas
@@ -2219,6 +2219,7 @@ type
   { TCustomConnection }
 
   TLoginEvent = procedure(Sender: TObject; Username, Password: string) of object;
+  TCloseErrorEvent = procedure(Sender : TObject; aError : Exception) of object;
 
   TCustomConnection = class(TComponent)
   private
@@ -2228,6 +2229,7 @@ type
     FBeforeDisconnect: TNotifyEvent;
     FForcedClose: Boolean;
     FLoginPrompt: Boolean;
+    FOnCloseError: TCloseErrorEvent;
     FOnLogin: TLoginEvent;
     FStreamedConnected: Boolean;
     procedure SetAfterConnect(const AValue: TNotifyEvent);
@@ -2235,6 +2237,8 @@ type
     procedure SetBeforeConnect(const AValue: TNotifyEvent);
     procedure SetBeforeDisconnect(const AValue: TNotifyEvent);
   protected
+    Procedure DoCloseError(aError : Exception);
+    procedure CloseForDestroy;
     procedure DoLoginPrompt; virtual;
     procedure DoConnect; virtual;
     procedure DoDisconnect; virtual;
@@ -2263,6 +2267,7 @@ type
     property BeforeConnect : TNotifyEvent read FBeforeConnect write SetBeforeConnect;
     property BeforeDisconnect : TNotifyEvent read FBeforeDisconnect write SetBeforeDisconnect;
     property OnLogin: TLoginEvent read FOnLogin write FOnLogin;
+    Property OnCloseError : TCloseErrorEvent Read FOnCloseError Write FOnCloseError;
   end;
 
 
diff --git a/packages/fcl-db/src/sqldb/sqldb.pp b/packages/fcl-db/src/sqldb/sqldb.pp
index 81fc74bf77..839b32b063 100644
--- a/packages/fcl-db/src/sqldb/sqldb.pp
+++ b/packages/fcl-db/src/sqldb/sqldb.pp
@@ -1410,7 +1410,7 @@ end;
 destructor TSQLConnection.Destroy;
 begin
   try
-    Connected:=False; // needed because we want to de-allocate statements
+    CloseForDestroy; // needed because we want to de-allocate statements
   Finally  
     FreeAndNil(FStatements);
     inherited Destroy;