--- Merging r25099 into '.':

U    packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r25248 into '.':
G    packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r25249 into '.':
G    packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r25250 into '.':
G    packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r25251 into '.':
U    packages/fcl-db/src/sqldb/sqldb.pp
--- Merging r25252 into '.':
G    packages/fcl-db/src/sqldb/sqldb.pp
--- Merging r25293 into '.':
U    packages/fcl-db/src/base/db.pas
--- Merging r25294 into '.':
G    packages/fcl-db/src/base/db.pas
U    packages/fcl-db/src/base/fields.inc
--- Merging r25313 into '.':
U    packages/fcl-db/src/base/bufdataset.pas
--- Merging r25314 into '.':
G    packages/fcl-db/src/base/bufdataset.pas
--- Merging r25326 into '.':
U    packages/fcl-db/tests/bufdatasettoolsunit.pas
U    packages/fcl-db/tests/testdbbasics.pas
--- Merging r25327 into '.':
U    packages/fcl-db/tests/dbtestframework_gui.lpi
U    packages/fcl-db/tests/dbtestframework_gui.lpr
U    packages/fcl-db/tests/inieditor.lfm
A    packages/fcl-db/tests/dbguitestrunner.pas
U    packages/fcl-db/tests/inieditor.pas
U    packages/fcl-db/tests/sqldbtoolsunit.pas

# revisions: 25099,25248,25249,25250,25251,25252,25293,25294,25313,25314,25326,25327
r25099 | ludob | 2013-07-14 15:08:06 +0200 (Sun, 14 Jul 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

pqconnection: changed FCursorCount to dword to avoid 'prepared statement already exists' errors when preparing more than 64k queries in one transaction while keeping one ore more queries open
r25248 | michael | 2013-08-12 09:25:21 +0200 (Mon, 12 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

* Thread-safe connection pool
r25249 | michael | 2013-08-12 09:48:08 +0200 (Mon, 12 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

* Reworked pool to a thread list
r25250 | michael | 2013-08-12 10:19:00 +0200 (Mon, 12 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

* Fixed ROLLBACK : all statements must be unprepared
r25251 | michael | 2013-08-12 14:44:03 +0200 (Mon, 12 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/sqldb/sqldb.pp

* Mark transaction as closed in caNone case of EndTranscation
r25252 | michael | 2013-08-12 14:56:16 +0200 (Mon, 12 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/sqldb/sqldb.pp

* Restore old behaviour for caNone for Action
r25293 | lacak | 2013-08-19 13:43:16 +0200 (Mon, 19 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/base/db.pas

fcl-db: base: formatting (char-case)
r25294 | lacak | 2013-08-19 14:06:36 +0200 (Mon, 19 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/base/db.pas
   M /trunk/packages/fcl-db/src/base/fields.inc

fcl-db: base: implements AsBytes for TBlobField
r25313 | lacak | 2013-08-20 08:11:06 +0200 (Tue, 20 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/base/bufdataset.pas

fcl-db: bufdataset: formatting
r25314 | lacak | 2013-08-20 08:42:09 +0200 (Tue, 20 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/src/base/bufdataset.pas

fcl-db: bufdataset: partialy fixes TestOpeningNonExistingDataset. See also #22030.
r25326 | lacak | 2013-08-22 11:57:45 +0200 (Thu, 22 Aug 2013) | 1 line
Changed paths:
   M /trunk/packages/fcl-db/tests/bufdatasettoolsunit.pas
   M /trunk/packages/fcl-db/tests/testdbbasics.pas

fcl-db: tests: formatting
r25327 | reiniero | 2013-08-22 13:07:39 +0200 (Thu, 22 Aug 2013) | 2 lines
Changed paths:
   A /trunk/packages/fcl-db/tests/dbguitestrunner.pas
   M /trunk/packages/fcl-db/tests/dbtestframework_gui.lpi
   M /trunk/packages/fcl-db/tests/dbtestframework_gui.lpr
   M /trunk/packages/fcl-db/tests/inieditor.lfm
   M /trunk/packages/fcl-db/tests/inieditor.pas
   M /trunk/packages/fcl-db/tests/sqldbtoolsunit.pas

sqldb: tests: clean up forms so database.ini editor is in main form

git-svn-id: branches/fixes_2_6@25470 -

.gitattributes

@@ -2013,6 +2013,7 @@ packages/fcl-db/tests/README.txt svneol=native#text/plain
 packages/fcl-db/tests/bufdatasettoolsunit.pas svneol=native#text/plain
 packages/fcl-db/tests/database.ini.txt svneol=native#text/plain
 packages/fcl-db/tests/dbftoolsunit.pas svneol=native#text/plain
+packages/fcl-db/tests/dbguitestrunner.pas svneol=native#text/plain
 packages/fcl-db/tests/dbtestframework.pas svneol=native#text/plain
 packages/fcl-db/tests/dbtestframework_gui.lpi svneol=native#text/plain
 packages/fcl-db/tests/dbtestframework_gui.lpr svneol=native#text/plain

packages/fcl-db/src/base/bufdataset.pas

@@ -176,8 +176,6 @@ type
     property BookmarkSize : integer read GetBookmarkSize;
   end;
   
-  TDataPacketFormat = (dfBinary,dfXML,dfXMLUTF8,dfAny);
-
   { TDoubleLinkedBufIndex }
 
   TDoubleLinkedBufIndex = class(TBufIndex)
@@ -344,6 +342,8 @@ type
 
   { TDataPacketReader }
 
+  TDataPacketFormat = (dfBinary,dfXML,dfXMLUTF8,dfAny);
+
   TDatapacketReaderClass = class of TDatapacketReader;
   TDataPacketReader = class(TObject)
     FStream : TStream;
@@ -1129,21 +1129,23 @@ begin
   // If there are less fields then FieldDefs we know for sure that the dataset
   // is not (correctly) created.
 
-  // commented for now. If there are constant expressions in the select
-  // statement they are ftUnknown, and not created.
+  // If there are constant expressions in the select statement (for PostgreSQL)
+  // they are of type ftUnknown (in FieldDefs), and are not created (in Fields).
+  // So Fields.Count < FieldDefs.Count in this case
   // See mantis #22030
 
   //  if Fields.Count<FieldDefs.Count then
-  //    DatabaseError(SErrNoDataset);
+  if Fields.Count = 0 then
+    DatabaseError(SErrNoDataset);
 
   // If there is a field with FieldNo=0 then the fields are not found to the
   // FieldDefs which is a sign that there is no dataset created. (Calculated and
   // lookup fields have FieldNo=-1)
   for i := 0 to Fields.Count-1 do
-    if fields[i].FieldNo=0 then
+    if Fields[i].FieldNo=0 then
       DatabaseError(SErrNoDataset)
-    else if (FAutoIncValue>-1) and (fields[i] is TAutoIncField) and not assigned(FAutoIncField) then
-      FAutoIncField := TAutoIncField(fields[i]);
+    else if (FAutoIncValue>-1) and (Fields[i] is TAutoIncField) and not assigned(FAutoIncField) then
+      FAutoIncField := TAutoIncField(Fields[i]);
 
   InitDefaultIndexes;
   CalcRecordSize;
@@ -2662,19 +2664,6 @@ begin
     end;
 end;
 
-procedure TCustomBufDataset.SaveToFile(AFileName: string;
-  Format: TDataPacketFormat);
-var AFileStream : TFileStream;
-begin
-  if AFileName='' then AFileName := FFileName;
-  AFileStream := TFileStream.Create(AFileName,fmCreate);
-  try
-    SaveToStream(AFileStream, Format);
-  finally
-    AFileStream.Free;
-  end;
-end;
-
 procedure TCustomBufDataset.SetDatasetPacket(AReader: TDataPacketReader);
 begin
   FDatasetReader := AReader;
@@ -2828,31 +2817,43 @@ begin
   end;
 end;
 
-procedure TCustomBufDataset.CreateDataset;
-var AStoreFilename: string;
+procedure TCustomBufDataset.SaveToFile(AFileName: string;
+  Format: TDataPacketFormat);
+var AFileStream : TFileStream;
+begin
+  if AFileName='' then AFileName := FFileName;
+  AFileStream := TFileStream.Create(AFileName,fmCreate);
+  try
+    SaveToStream(AFileStream, Format);
+  finally
+    AFileStream.Free;
+  end;
+end;
 
+procedure TCustomBufDataset.CreateDataset;
+var AStoreFileName: string;
 begin
   CheckInactive;
   if ((FieldCount=0) or (FieldDefs.Count=0)) then
     begin
     if (FieldDefs.Count>0) then
       CreateFields
-    else if (fields.Count>0) then
+    else if (Fields.Count>0) then
       begin
-      InitFieldDefsFromfields;
+      InitFieldDefsFromFields;
       BindFields(True);
       end
     else
       raise Exception.Create(SErrNoFieldsDefined);
     FAutoIncValue:=1;
     end;
-  // When a filename is set, do not read from this file
-  AStoreFilename:=FFileName;
+  // When a FileName is set, do not read from this file
+  AStoreFileName:=FFileName;
   FFileName := '';
   try
     Open;
   finally
-    FFileName:=AStoreFilename;
+    FFileName:=AStoreFileName;
   end;
 end;
 

packages/fcl-db/src/base/db.pas

@@ -72,8 +72,8 @@ type
   TFields = Class;
   TDataSet = class;
   TDataBase = Class;
-  TDatasource = Class;
-  TDatalink = Class;
+  TDataSource = Class;
+  TDataLink = Class;
   TDBTransaction = Class;
 
 { Exception classes }
@@ -864,15 +864,17 @@ type
     Function GetBlobStream (Mode : TBlobStreamMode) : TStream;
   protected
     procedure FreeBuffers; override;
+    function GetAsBytes: TBytes; override;
     function GetAsString: string; override;
     function GetAsVariant: Variant; override;
+    function GetAsWideString: WideString; override;
     function GetBlobSize: Longint; virtual;
     function GetIsNull: Boolean; override;
     procedure GetText(var TheText: string; ADisplayText: Boolean); override;
+    procedure SetAsBytes(const AValue: TBytes); override;
     procedure SetAsString(const AValue: string); override;
     procedure SetText(const AValue: string); override;
     procedure SetVarValue(const AValue: Variant); override;
-    function GetAsWideString: WideString; override;
     procedure SetAsWideString(const AValue: WideString); override;
   public
     constructor Create(AOwner: TComponent); override;
@@ -1402,7 +1404,7 @@ type
     Procedure DoInternalOpen;
     Function  GetBuffer (Index : longint) : TRecordBuffer;
     Function  GetField (Index : Longint) : TField;
-    Procedure RegisterDataSource(ADatasource : TDataSource);
+    Procedure RegisterDataSource(ADataSource : TDataSource);
     Procedure RemoveField (Field : TField);
     procedure SetConstraints(Value: TCheckConstraints);
     Procedure SetField (Index : Longint;Value : TField);
@@ -1410,7 +1412,7 @@ type
     Procedure ShiftBuffersBackward;
     Function  TryDoing (P : TDataOperation; Ev : TDatasetErrorEvent) : Boolean;
     Function GetActive : boolean;
-    Procedure UnRegisterDataSource(ADatasource : TDatasource);
+    Procedure UnRegisterDataSource(ADataSource : TDataSource);
     Procedure UpdateFieldDefs;
     procedure SetBlockReadSize(AValue: Integer); virtual;
     Procedure SetFieldDefs(AFieldDefs: TFieldDefs);

packages/fcl-db/src/base/fields.inc

@@ -2737,7 +2737,7 @@ end;
 
 { TBlobField }
 
-Function TBlobField.GetBlobStream(Mode : TBlobStreamMode) : TStream;
+function TBlobField.GetBlobStream(Mode: TBlobStreamMode): TStream;
 
 begin
   Result:=FDataset.CreateBlobStream(Self,Mode);
@@ -2748,6 +2748,24 @@ procedure TBlobField.FreeBuffers;
 begin
 end;
 
+function TBlobField.GetAsBytes: TBytes;
+var
+  Stream : TStream;
+  Len    : Integer;
+begin
+  Stream := GetBlobStream(bmRead);
+  if Stream <> nil then
+    try
+      Len := Stream.Size;
+      SetLength(Result, Len);
+      if Len > 0 then
+        Stream.ReadBuffer(Result[0], Len);
+    finally
+      Stream.Free;
+    end
+  else
+    SetLength(Result, 0);
+end;
 
 function TBlobField.GetAsString: string;
 var
@@ -2756,7 +2774,7 @@ var
 begin
   Stream := GetBlobStream(bmRead);
   if Stream <> nil then
-    With Stream do
+    with Stream do
       try
         Len := Size;
         SetLength(Result, Len);
@@ -2776,7 +2794,7 @@ var
 begin
   Stream := GetBlobStream(bmRead);
   if Stream <> nil then
-    With Stream do
+    with Stream do
       try
         Len := Size;
         SetLength(Result, (Len+1) div 2);
@@ -2799,7 +2817,8 @@ begin
     s := GetAsString;
     result := s;
     end
-  else result := Null;
+  else
+    result := Null;
 end;
 
 
@@ -2807,29 +2826,29 @@ function TBlobField.GetBlobSize: Longint;
 var
   Stream: TStream;
 begin
-  Stream := GetBlobStream(bmread);
+  Stream := GetBlobStream(bmRead);
   if Stream <> nil then
-    With Stream do
+    with Stream do
       try
         Result:=Size;
       finally
         Free;
       end
   else
-    result := 0;
+    Result := 0;
 end;
 
 
 function TBlobField.GetIsNull: Boolean;
 
 begin
-  If Not Modified then
-    result:= inherited GetIsnull
+  if Not Modified then
+    Result:= inherited GetIsNull
   else
-    With GetBlobStream(bmread) do
+    with GetBlobStream(bmRead) do
       try
         Result:=(Size=0);
-      Finally
+      finally
         Free;
       end;
 end;
@@ -2841,12 +2860,26 @@ begin
   TheText:=inherited GetAsString;
 end;
 
+procedure TBlobField.SetAsBytes(const AValue: TBytes);
+var
+  Len : Integer;
+begin
+  with GetBlobStream(bmWrite) do
+    try
+      Len := Length(AValue);
+      if Len > 0 then
+        WriteBuffer(AValue[0], Len);
+    finally
+      Free;
+    end;
+end;
+
 
 procedure TBlobField.SetAsString(const AValue: string);
 var
   Len : Integer;
 begin
-  With GetBlobStream(bmwrite) do
+  with GetBlobStream(bmWrite) do
     try
       Len := Length(AValue);
       if Len > 0 then
@@ -2861,7 +2894,7 @@ procedure TBlobField.SetAsWideString(const AValue: WideString);
 var
   Len : Integer;
 begin
-  With GetBlobStream(bmwrite) do
+  with GetBlobStream(bmWrite) do
     try
       Len := Length(AValue) * 2;
       if Len > 0 then
@@ -2923,8 +2956,8 @@ end;
 procedure TBlobField.LoadFromStream(Stream: TStream);
 
 begin
-  With GetBlobStream(bmWrite) do
-    Try
+  with GetBlobStream(bmWrite) do
+    try
       CopyFrom(Stream,0);
     finally
       Free;

packages/fcl-db/src/sqldb/postgres/pqconnection.pp

@@ -15,19 +15,33 @@ uses
 {$EndIf}
 
 type
+  TPQCursor = Class;
+
+  { TPQTrans }
+
   TPQTrans = Class(TSQLHandle)
-    protected
+  protected
     PGConn        : PPGConn;
+    FList : TThreadList;
+    Procedure RegisterCursor(S : TPQCursor);
+    Procedure UnRegisterCursor(S : TPQCursor);
+  Public
+    Constructor Create;
+    Destructor Destroy; override;
   end;
 
+  { TPQCursor }
+
   TPQCursor = Class(TSQLCursor)
-    protected
+  protected
     Statement    : string;
     StmtName     : string;
     tr           : TPQTrans;
     res          : PPGresult;
     CurTuple     : integer;
     FieldBinding : array of integer;
+   Public
+    Destructor Destroy; override;
   end;
 
   EPQDatabaseError = class(EDatabaseError)
@@ -50,8 +64,8 @@ type
 
   TPQConnection = class (TSQLConnection)
   private
-    FConnectionPool      : array of TPQTranConnection;
-    FCursorCount         : word;
+    FConnectionPool      : TThreadList;
+    FCursorCount         : dword;
     FConnectString       : string;
     FIntegerDateTimes    : boolean;
     FVerboseErrors       : Boolean;
@@ -60,6 +74,11 @@ type
     function TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer) : TFieldType;
     procedure ExecuteDirectPG(const Query : String);
   protected
+    // Add connection to pool.
+    procedure AddConnection(T: TPQTranConnection);
+    // Release connection in pool.
+    procedure ReleaseConnection(Conn: PPGConn; DoClear : Boolean);
+
     procedure DoInternalConnect; override;
     procedure DoInternalDisconnect; override;
     function GetHandle : pointer; override;
@@ -86,6 +105,7 @@ type
     function RowsAffected(cursor: TSQLCursor): TRowsCount; override;
   public
     constructor Create(AOwner : TComponent); override;
+    destructor destroy; override;
     function GetConnectionInfo(InfoType:TConnInfoType): string; override;
     procedure CreateDB; override;
     procedure DropDB; override;
@@ -152,6 +172,53 @@ const Oid_Bool     = 16;
       oid_numeric   = 1700;
       Oid_uuid      = 2950;
 
+{ TPQTrans }
+
+procedure TPQTrans.RegisterCursor(S: TPQCursor);
+begin
+  FList.Add(S);
+  S.tr:=Self;
+end;
+
+procedure TPQTrans.UnRegisterCursor(S: TPQCursor);
+begin
+  S.tr:=Nil;
+  FList.Remove(S);
+end;
+
+constructor TPQTrans.Create;
+begin
+  Flist:=TThreadList.Create;
+  FList.Duplicates:=dupIgnore;
+end;
+
+destructor TPQTrans.Destroy;
+
+Var
+  L : TList;
+  I : integer;
+
+begin
+  L:=Flist.LockList;
+  try
+    For I:=0 to L.Count-1 do
+      TPQCursor(L[i]).tr:=Nil;
+  finally
+    Flist.UnlockList;
+  end;
+  FreeAndNil(FList);
+  inherited Destroy;
+end;
+
+{ TPQCursor }
+
+destructor TPQCursor.Destroy;
+begin
+  if Assigned(tr) then
+    Tr.UnRegisterCursor(Self);
+  inherited Destroy;
+end;
+
 
 constructor TPQConnection.Create(AOwner : TComponent);
 
@@ -160,6 +227,15 @@ begin
   FConnOptions := FConnOptions + [sqSupportParams] + [sqEscapeRepeat] + [sqEscapeSlash];
   FieldNameQuoteChars:=DoubleQuotes;
   VerboseErrors:=True;
+  FConnectionPool:=TThreadlist.Create;
+end;
+
+destructor TPQConnection.destroy;
+begin
+  // We must disconnect here. If it is done in inherited, then connection pool is gone.
+  Connected:=False;
+  FreeAndNil(FConnectionPool);
+  inherited destroy;
 end;
 
 procedure TPQConnection.CreateDB;
@@ -174,7 +250,7 @@ begin
   ExecuteDirectPG('DROP DATABASE ' +DatabaseName);
 end;
 
-procedure TPQConnection.ExecuteDirectPG(const query : string);
+procedure TPQConnection.ExecuteDirectPG(const Query: String);
 
 var ASQLDatabaseHandle    : PPGConn;
     res                   : PPGresult;
@@ -207,6 +283,39 @@ begin
 {$EndIf}
 end;
 
+procedure TPQConnection.AddConnection(T: TPQTranConnection);
+
+begin
+  FConnectionPool.Add(T);
+end;
+
+procedure TPQConnection.ReleaseConnection(Conn: PPGConn; DoClear: Boolean);
+
+Var
+  I : Integer;
+  L : TList;
+  T : TPQTranConnection;
+
+begin
+  L:=FConnectionPool.LockList;
+  // make connection available in pool
+  try
+    for i:=0 to L.Count-1 do
+      begin
+      T:=TPQTranConnection(L[i]);
+      if (T.FPGConn=Conn) then
+        begin
+        T.FTranActive:=false;
+        if DoClear then
+          T.FPGConn:=Nil;
+        break;
+        end;
+      end
+  finally
+    FConnectionPool.UnlockList;
+  end;
+end;
+
 
 function TPQConnection.GetTransactionHandle(trans : TSQLHandle): pointer;
 begin
@@ -218,23 +327,26 @@ var
   res : PPGresult;
   tr  : TPQTrans;
   i   : Integer;
+  L   : TList;
+
 begin
   result := false;
-
   tr := trans as TPQTrans;
-
+  L:=tr.FList.LockList;
+  try
+    For I:=0 to L.Count-1 do
+      begin
+      UnprepareStatement(TPQCursor(L[i]));
+      TPQCursor(L[i]).tr:=Nil;
+      end;
+    L.Clear;
+  finally
+    tr.flist.UnlockList;
+  end;
   res := PQexec(tr.PGConn, 'ROLLBACK');
-
   CheckResultError(res,tr.PGConn,SErrRollbackFailed);
-
   PQclear(res);
-  //make connection available in pool
-  for i:=0 to length(FConnectionPool)-1 do
-    if FConnectionPool[i].FPGConn=tr.PGConn then
-      begin
-      FConnectionPool[i].FTranActive:=false;
-      break;
-      end;
+  ReleaseConnection(tr.PGCOnn,false);
   result := true;
 end;
 
@@ -245,20 +357,12 @@ var
   i   : Integer;
 begin
   result := false;
-
   tr := trans as TPQTrans;
-
   res := PQexec(tr.PGConn, 'COMMIT');
   CheckResultError(res,tr.PGConn,SErrCommitFailed);
-
   PQclear(res);
   //make connection available in pool
-  for i:=0 to length(FConnectionPool)-1 do
-    if FConnectionPool[i].FPGConn=tr.PGConn then
-      begin
-      FConnectionPool[i].FTranActive:=false;
-      break;
-      end;
+  ReleaseConnection(tr.PGConn,false);
   result := true;
 end;
 
@@ -267,35 +371,47 @@ var
   res : PPGresult;
   tr  : TPQTrans;
   i   : Integer;
+  t : TPQTranConnection;
+  L : TList;
 begin
   result:=false;
   tr := trans as TPQTrans;
 
   //find an unused connection in the pool
   i:=0;
-  while i<length(FConnectionPool) do
-    if (FConnectionPool[i].FPGConn=nil) or not FConnectionPool[i].FTranActive then
-      break
-    else
+  t:=Nil;
+  L:=FConnectionPool.LockList;
+  try
+    while (I<L.Count-1) do
+      begin
+      T:=TPQTranConnection(L[i]);
+      if (T.FPGConn=nil) or not T.FTranActive then
+        break
+      else
+        T:=Nil;
       i:=i+1;
-  if i=length(FConnectionPool) then //create a new connection
+      end;
+    // set to active now, so when we exit critical section,
+    // it will be marked active and will not be found.
+    if Assigned(T) then
+      T.FTranActive:=true;
+  finally
+    FConnectionPool.UnLockList;
+  end;
+  if (T=Nil) then
+    begin
+    T:=TPQTranConnection.Create;
+    T.FTranActive:=True;
+    AddConnection(T);
+    end;
+  if (T.FPGConn<>nil) then
+    tr.PGConn:=T.FPGConn
+  else
     begin
     tr.PGConn := PQconnectdb(pchar(FConnectString));
     CheckConnectionStatus(tr.PGConn);
-
     if CharSet <> '' then
       PQsetClientEncoding(tr.PGConn, pchar(CharSet));
-
-    //store the new connection
-    SetLength(FConnectionPool,i+1);
-    FConnectionPool[i]:=TPQTranConnection.Create;
-    FConnectionPool[i].FPGConn:=tr.PGConn;
-    FConnectionPool[i].FTranActive:=true;
-    end
-  else //re-use existing connection
-    begin
-    tr.PGConn:=FConnectionPool[i].FPGConn;
-    FConnectionPool[i].FTranActive:=true;
     end;
 
   res := PQexec(tr.PGConn, 'BEGIN');
@@ -339,7 +455,10 @@ end;
 
 
 procedure TPQConnection.DoInternalConnect;
-var ASQLDatabaseHandle   : PPGConn;
+var
+  ASQLDatabaseHandle   : PPGConn;
+  T : TPQTranConnection;
+
 begin
 {$IfDef LinkDynamically}
   InitialisePostgres3;
@@ -365,24 +484,33 @@ begin
   // This only works for pg>=8.0, so timestamps won't work with earlier versions of pg which are compiled with integer_datetimes on
   if PQparameterStatus<>nil then
     FIntegerDateTimes := PQparameterStatus(ASQLDatabaseHandle,'integer_datetimes') = 'on';
-
-  SetLength(FConnectionPool,1);
-  FConnectionPool[0]:=TPQTranConnection.Create;
-  FConnectionPool[0].FPGConn:=ASQLDatabaseHandle;
-  FConnectionPool[0].FTranActive:=false;
+  T:=TPQTranConnection.Create;
+  T.FPGConn:=ASQLDatabaseHandle;
+  T.FTranActive:=false;
+  AddConnection(T);
 end;
 
 procedure TPQConnection.DoInternalDisconnect;
-var i:integer;
+var
+  i:integer;
+  L : TList;
+  T : TPQTranConnection;
+
 begin
   Inherited;
-  for i:=0 to length(FConnectionPool)-1 do
-    begin
-    if assigned(FConnectionPool[i].FPGConn) then
-      PQfinish(FConnectionPool[i].FPGConn);
-    FConnectionPool[i].Free;
-    end;
-  Setlength(FConnectionPool,0);
+  L:=FConnectionPool.LockList;
+  try
+    for i:=0 to L.Count-1 do
+      begin
+      T:=TPQTranConnection(L[i]);
+      if assigned(T.FPGConn) then
+        PQfinish(T.FPGConn);
+      T.Free;
+      end;
+    L.Clear;
+  finally
+    FConnectionPool.UnLockList;
+  end;
 {$IfDef LinkDynamically}
   ReleasePostgres3;
 {$EndIf}
@@ -396,13 +524,7 @@ begin
     begin
     sErr := PQerrorMessage(conn);
     //make connection available in pool
-    for i:=0 to length(FConnectionPool)-1 do
-      if FConnectionPool[i].FPGConn=conn then
-        begin
-        FConnectionPool[i].FPGConn:=nil;
-        FConnectionPool[i].FTranActive:=false;
-        break;
-        end;
+    ReleaseConnection(Conn,True);
     PQfinish(conn);
     DatabaseError(sErrConnectionFailed + ' (PostgreSQL: ' + sErr + ')', Self);
     end;
@@ -463,14 +585,7 @@ begin
     if assigned(conn) then
       begin
       PQFinish(conn);
-      //make connection available in pool
-      for i:=0 to length(FConnectionPool)-1 do
-        if FConnectionPool[i].FPGConn=conn then
-          begin
-          FConnectionPool[i].FPGConn:=nil;
-          FConnectionPool[i].FTranActive:=false;
-          break;
-          end;
+      ReleaseConnection(Conn,True);
       end;
     raise E;
     end;
@@ -549,18 +664,18 @@ begin
   end;
 end;
 
-Function TPQConnection.AllocateCursorHandle : TSQLCursor;
+function TPQConnection.AllocateCursorHandle: TSQLCursor;
 
 begin
   result := TPQCursor.create;
 end;
 
-Procedure TPQConnection.DeAllocateCursorHandle(var cursor : TSQLCursor);
+procedure TPQConnection.DeAllocateCursorHandle(var cursor: TSQLCursor);
 begin
   FreeAndNil(cursor);
 end;
 
-Function TPQConnection.AllocateTransactionHandle : TSQLHandle;
+function TPQConnection.AllocateTransactionHandle: TSQLHandle;
 
 begin
   result := TPQTrans.create;
@@ -625,8 +740,9 @@ begin
     if FStatementType in [stInsert,stUpdate,stDelete, stSelect] then
       begin
       StmtName := 'prepst'+inttostr(FCursorCount);
-      inc(FCursorCount);
-      tr := TPQTrans(aTransaction.Handle);
+      InterlockedIncrement(FCursorCount);
+      TPQTrans(aTransaction.Handle).RegisterCursor(Cursor as TPQCursor);
+
       // Only available for pq 8.0, so don't use it...
       // Res := pqprepare(tr,'prepst'+name+nr,pchar(buf),params.Count,pchar(''));
       s := 'prepare '+StmtName+' ';
@@ -755,7 +871,8 @@ begin
       end
     else
       begin
-      tr := TPQTrans(aTransaction.Handle);
+      // Registercursor sets tr
+      TPQTrans(aTransaction.Handle).RegisterCursor(Cursor as TPQCursor);
 
       if Assigned(AParams) and (AParams.Count > 0) then
         begin
@@ -816,26 +933,39 @@ end;
 function TPQConnection.GetHandle: pointer;
 var
   i:integer;
+  L : TList;
+  T : TPQTranConnection;
+
 begin
   result:=nil;
   if not Connected then
     exit;
   //Get any handle that is (still) connected
-  for i:=0 to length(FConnectionPool)-1 do
-    if assigned(FConnectionPool[i].FPGConn) and (PQstatus(FConnectionPool[i].FPGConn)<>CONNECTION_BAD) then
+  L:=FConnectionPool.LockList;
+  try
+    I:=L.Count-1;
+    While (I>=0) and (Result=Nil) do
       begin
-      Result :=FConnectionPool[i].FPGConn;
-      exit;
+      T:=TPQTranConnection(L[i]);
+      if assigned(T.FPGConn) and (PQstatus(T.FPGConn)<>CONNECTION_BAD) then
+        Result:=T.FPGConn;
+      Dec(I);
       end;
+  finally
+    FConnectionPool.UnLockList;
+  end;
+  if Result<>Nil then
+     exit;
   //Nothing connected!! Reconnect
-  if assigned(FConnectionPool[0].FPGConn) then
-    PQreset(FConnectionPool[0].FPGConn)
+  // T is element 0 after loop
+  if assigned(T.FPGConn) then
+    PQreset(T.FPGConn)
   else
-    FConnectionPool[0].FPGConn := PQconnectdb(pchar(FConnectString));
-  CheckConnectionStatus(FConnectionPool[0].FPGConn);
+    T.FPGConn := PQconnectdb(pchar(FConnectString));
+  CheckConnectionStatus(T.FPGConn);
   if CharSet <> '' then
-    PQsetClientEncoding(FConnectionPool[0].FPGConn, pchar(CharSet));
-  result:=FConnectionPool[0].FPGConn;
+    PQsetClientEncoding(T.FPGConn, pchar(CharSet));
+  result:=T.FPGConn;
 end;
 
 function TPQConnection.Fetch(cursor : TSQLCursor) : boolean;

packages/fcl-db/src/sqldb/sqldb.pp

@@ -1248,11 +1248,11 @@ procedure TSQLTransaction.EndTransaction;
 
 begin
   Case Action of
-    caNone : ;
     caCommit :
       Commit;
     caCommitRetaining :
       CommitRetaining;
+    caNone,
     caRollback :
       RollBack;
     caRollbackRetaining :
@@ -1350,6 +1350,7 @@ end;
 destructor TSQLTransaction.Destroy;
 begin
   EndTransaction;
+  FreeAndNil(FTrans);
   FreeAndNil(FParams);
   inherited Destroy;
 end;

packages/fcl-db/tests/bufdatasettoolsunit.pas

@@ -6,8 +6,8 @@ A closed BufDataset normally has no data, so these tests won't work.
 
 To circumvent this, this unit saves the dataset contents to file and reloads them on opening
 using the BufDataset persistence mechanism.
-
 }
+
 {$mode objfpc}{$H+}
 
 interface
@@ -18,7 +18,6 @@ uses
   BufDataset;
 
 type
-{ TbufdatasetConnector }
 
   { TbufdatasetDBConnector }
 

packages/fcl-db/tests/dbguitestrunner.pas

@@ -0,0 +1,68 @@
+unit DBGuiTestRunner;
+// Adds database.ini editing facilities to regular GuiTestRunner form
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils,
+  Interfaces, Forms,
+  StdCtrls,
+  GuiTestRunner, inieditor;
+
+type
+
+  { TDBGuiTestRunnerForm }
+
+  TDBGuiTestRunnerForm=class(TGUITestRunner)
+  private
+    DBEditButton: TButton;
+  public
+    procedure DBEditButtonClick(ASender: TObject);
+    constructor Create(AOwner: TComponent); override;
+  end;
+
+var
+  DBGuiTestRunnerForm: TDBGuiTestRunnerForm;
+
+
+implementation
+
+
+{ TDBGuiTestRunnerForm }
+
+procedure TDBGuiTestRunnerForm.DBEditButtonClick(ASender: TObject);
+var
+  DBSelectForm: TFormIniEditor;
+begin
+  DBSelectForm:=TFormIniEditor.Create(nil);
+  try
+    DBSelectForm.INIFile:='database.ini';
+    DBSelectForm.ProfileSelectSection:='Database';
+    DBSelectForm.ProfileSelectKey:='type';
+    // We can ignore resulting db selection as the file is saved already:
+    DBSelectForm.ShowModal;
+  finally
+    DBSelectForm.Free;
+  end;
+end;
+
+constructor TDBGuiTestRunnerForm.Create(AOwner: TComponent);
+// Add our database.ini edit button to the existing GUI
+begin
+  inherited Create(AOwner);
+  DBEditButton:=TButton.Create(Self);
+  DBEditButton.Top:=7;
+  DBEditButton.Left:=210;
+  DBEditButton.Height:=32;
+  DBEditButton.Width:=100;
+  DBEditButton.Caption:='Edit database.ini...';
+  DBEditButton.Hint:='Edit database selection settings (effective for next start)';
+  DBEditButton.OnClick:=@DBEditButtonClick;
+  // Set this last; now all properties take effect
+  DBEditButton.Parent:=Self.Panel1;
+end;
+
+end.
+

packages/fcl-db/tests/dbtestframework_gui.lpi

@@ -1,10 +1,14 @@
-<?xml version="1.0"?>
+<?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
     <Version Value="9"/>
     <General>
+      <Flags>
+        <MainUnitHasCreateFormStatements Value="False"/>
+      </Flags>
       <SessionStorage Value="InProjectDir"/>
       <MainUnit Value="0"/>
+      <Title Value="DBTestFramework"/>
       <ResourceType Value="res"/>
       <UseXPManifest Value="True"/>
     </General>
@@ -76,12 +80,17 @@
         <PackageName Value="FCL"/>
       </Item4>
     </RequiredPackages>
-    <Units Count="1">
+    <Units Count="2">
       <Unit0>
         <Filename Value="dbtestframework_gui.lpr"/>
         <IsPartOfProject Value="True"/>
         <UnitName Value="dbtestframework_gui"/>
       </Unit0>
+      <Unit1>
+        <Filename Value="dbguitestrunner.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="DBGuiTestRunner"/>
+      </Unit1>
     </Units>
   </ProjectOptions>
   <CompilerOptions>

packages/fcl-db/tests/dbtestframework_gui.lpr

@@ -14,10 +14,11 @@ program dbtestframework_gui;
 uses
   Interfaces, Forms,
   // GUI:
-  GuiTestRunner, inieditor,
+  StdCtrls {to extend GuiTestRunner},
+  DBGuiTestRunner, inieditor,
   // Generic DB test framework units
   ToolsUnit,
-  // Connectors for different database-types
+  // Connectors for different database types
   sqldbtoolsunit,
   dbftoolsunit,
   bufdatasettoolsunit,
@@ -37,29 +38,10 @@ uses
 
 {$R *.res}
 
-var
-  DBSelectForm: TFormIniEditor;
-  TestRunForm: TGUITestRunner;
 begin
+  Application.Title:='DBTestFramework';
   Application.Initialize;
-  DBSelectForm:=TFormIniEditor.Create(nil);
-  try
-    DBSelectForm.INIFile:='database.ini';
-    DBSelectForm.ProfileSelectSection:='Database';
-    DBSelectForm.ProfileSelectKey:='type';
-    // We can ignore resulting db selection as the file is saved already:
-    DBSelectForm.ShowModal;
-  finally
-    DBSelectForm.Free;
-  end;
-  // Manually run this form because autocreation could have loaded an old
-  // database.ini file (if the user changed it using DBSelectForm)
-  TestRunForm:=TGUITestRunner.Create(nil);
-  try
-    TestRunForm.Show;
-    Application.Run;
-  finally
-    TestRunForm.Free;
-  end;
+  Application.CreateForm(TDBGuiTestRunnerForm, DBGuiTestRunnerForm);
+  Application.Run;
 end.
 

packages/fcl-db/tests/inieditor.lfm

@@ -454,12 +454,14 @@ object FormIniEditor: TFormIniEditor
     Lines.Strings = (
       ''
     )
+    SelectedColor.FrameEdges = sfeAround
     SelectedColor.BackPriority = 50
     SelectedColor.ForePriority = 50
     SelectedColor.FramePriority = 50
     SelectedColor.BoldPriority = 50
     SelectedColor.ItalicPriority = 50
     SelectedColor.UnderlinePriority = 50
+    SelectedColor.StrikeOutPriority = 50
     OnStatusChange = SynMemoStatusChange
     inline SynLeftGutterPartList1: TSynGutterPartList
       object SynGutterMarks1: TSynGutterMarks
@@ -471,6 +473,7 @@ object FormIniEditor: TFormIniEditor
         MouseActions = <>
         MarkupInfo.Background = clBtnFace
         MarkupInfo.Foreground = clNone
+        MarkupInfo.FrameEdges = sfeAround
         DigitCount = 2
         ShowOnlyLineNumbersMultiplesOf = 1
         ZeroStart = False
@@ -485,11 +488,15 @@ object FormIniEditor: TFormIniEditor
       object SynGutterSeparator1: TSynGutterSeparator
         Width = 2
         MouseActions = <>
+        MarkupInfo.Background = clWhite
+        MarkupInfo.Foreground = clGray
+        MarkupInfo.FrameEdges = sfeAround
       end
       object SynGutterCodeFolding1: TSynGutterCodeFolding
         MouseActions = <>
         MarkupInfo.Background = clNone
         MarkupInfo.Foreground = clGray
+        MarkupInfo.FrameEdges = sfeAround
         MouseActionsExpanded = <>
         MouseActionsCollapsed = <>
       end
@@ -497,7 +504,7 @@ object FormIniEditor: TFormIniEditor
   end
   object FileNameEdit: TFileNameEdit
     Left = 56
-    Height = 23
+    Height = 21
     Top = 24
     Width = 368
     OnAcceptFileName = FileNameEditAcceptFileName
@@ -510,28 +517,28 @@ object FormIniEditor: TFormIniEditor
   end
   object INIFileLabel: TLabel
     Left = 8
-    Height = 15
+    Height = 13
     Top = 24
-    Width = 34
+    Width = 32
     Caption = 'INI file'
     ParentColor = False
   end
   object ProfileSelect: TComboBox
     Left = 56
-    Height = 23
+    Height = 21
     Hint = 'Choose the profile you want to enable'
     Top = 61
     Width = 164
-    ItemHeight = 15
+    ItemHeight = 13
     OnSelect = ProfileSelectSelect
     Sorted = True
     TabOrder = 1
   end
   object ProfileLabel: TLabel
     Left = 8
-    Height = 15
+    Height = 13
     Top = 64
-    Width = 34
+    Width = 30
     Caption = 'Profile'
     ParentColor = False
   end
@@ -556,6 +563,17 @@ object FormIniEditor: TFormIniEditor
     OnClick = CancelButtonClick
     TabOrder = 3
   end
+  object Label1: TLabel
+    Left = 8
+    Height = 13
+    Top = 0
+    Width = 229
+    Caption = 'Changes need a program restart to load!'
+    Font.Color = clRed
+    Font.Style = [fsBold]
+    ParentColor = False
+    ParentFont = False
+  end
   object SynIniHighlighter: TSynIniSyn
     DefaultFilter = 'INI Files (*.ini)|*.ini'
     Enabled = False

packages/fcl-db/tests/inieditor.pas

@@ -15,6 +15,7 @@ type
 
   TFormIniEditor = class(TForm)
     GUITimer: TIdleTimer;
+    Label1: TLabel;
     OKButton: TButton;
     CancelButton: TButton;
     ProfileSelect: TComboBox;

packages/fcl-db/tests/sqldbtoolsunit.pas

@@ -14,7 +14,7 @@ uses
   {$ENDIF WIN64}
   ,odbcconn
   {$IFNDEF WIN64}
-  {See packages\fcl-db\fpmake.pp: Oracle connector is not built if PostgreSQL connectoris not built}
+  {See packages\fcl-db\fpmake.pp: Oracle connector not built yet on Win64}
   ,oracleconnection
   {$ENDIF WIN64}
   ,sqlite3conn

packages/fcl-db/tests/testdbbasics.pas

@@ -324,11 +324,11 @@ begin
     begin
     aDatasource.DataSet := ds;
     DataEvents := '';
-    open;
-    Fields.add(tfield.Create(DBConnector.GetNDataset(1)));
+    Open;
+    Fields.Add(TField.Create(ds));
     CheckEquals('deUpdateState:0;deFieldListChange:0;',DataEvents);
     DataEvents := '';
-    fields.Clear;
+    Fields.Clear;
     CheckEquals('deFieldListChange:0;',DataEvents)
     end;
   aDatasource.Free;
@@ -1319,7 +1319,6 @@ begin
     first;
     CheckTrue(EOF);
 
-
     Close;
     end;
 end;
@@ -1327,14 +1326,13 @@ end;
 {$ifdef fpc}
 procedure TTestBufDatasetDBBasics.TestIsEmpty;
 begin
-  with tCustombufdataset(DBConnector.GetNDataset(True,1)) do
+  with DBConnector.GetNDataset(True,1) as TCustomBufDataset do
     begin
     open;
     delete;
     Resync([]);
-    applyupdates;
+    ApplyUpdates;
     CheckTrue(IsEmpty);
-
     end;
 end;
 
@@ -2333,7 +2331,6 @@ var i          : byte;
     DbfTableLevel: integer;
 
 begin
-  DbfTableLevel:=4;
   if (uppercase(dbconnectorname)='DBF') then
   begin
     DbfTableLevel:=strtointdef(dbconnectorparams,4);
@@ -2359,7 +2356,8 @@ var i          : byte;
 
 begin
   if (uppercase(dbconnectorname)='DBF') then
-    Ignore('TDBF Smallint support only from -999 to 9999');
+    Ignore('TDBF: Smallint support only from -999 to 9999');
+
   TestfieldDefinition(ftSmallint,2,ds,Fld);
 
   for i := 0 to testValuesCount-1 do
@@ -2498,7 +2496,8 @@ var i          : byte;
 
 begin
   if (uppercase(dbconnectorname)='DBF') then
-    Ignore('This test does not apply to TDDBF as they store currency in BCD fields.');
+    Ignore('This test does not apply to TDBF as they store currency in BCD fields.');
+
   TestfieldDefinition(ftCurrency,8,ds,Fld);
 
   for i := 0 to testValuesCount-1 do