Browse Source

--- Merging r23168 into '.':
U packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r23169 into '.':
U packages/fcl-db/tests/testfieldtypes.pas
--- Merging r23189 into '.':
U packages/fcl-db/tests/toolsunit.pas
--- Merging r23190 into '.':
U packages/fcl-db/src/dbase/dbf.pas
--- Merging r23191 into '.':
D packages/fcl-db/tests/dbfexporttestcase1.pas
--- Merging r23192 into '.':
U packages/fcl-db/tests/testdbbasics.pas
--- Merging r23198 into '.':
G packages/fcl-db/tests/testfieldtypes.pas
G packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r23200 into '.':
G packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r23228 into '.':
G packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r23307 into '.':
G packages/fcl-db/tests/testdbbasics.pas
U packages/fcl-db/src/base/dataset.inc
U packages/fcl-db/src/base/bufdataset.pas
--- Merging r23439 into '.':
U packages/fcl-db/src/codegen/fpddcodegen.pp
--- Merging r23440 into '.':
U packages/fcl-db/src/codegen/fpcgtiopf.pp
--- Merging r23445 into '.':
G packages/fcl-db/src/sqldb/postgres/pqconnection.pp
--- Merging r23455 into '.':
U packages/fcl-db/src/sqldb/sqldb.pp

# revisions: 23168,23169,23189,23190,23191,23192,23198,23200,23228,23307,23439,23440,23445,23455
r23168 | lacak | 2012-12-18 08:17:10 +0100 (Tue, 18 Dec 2012) | 3 lines
Changed paths:
M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

fcl-db: postgresql:
* check transaction state to determine failed transaction. To avoid "current transaction is aborted commands ignored until end of transaction block"
* move GetPQErrorMessage into CheckResultError as it was originally in rev.21750
r23169 | lacak | 2012-12-18 08:34:41 +0100 (Tue, 18 Dec 2012) | 1 line
Changed paths:
M /trunk/packages/fcl-db/tests/testfieldtypes.pas

fcl-db: tests: formatting (reorder methods)
r23189 | lacak | 2012-12-19 09:27:04 +0100 (Wed, 19 Dec 2012) | 1 line
Changed paths:
M /trunk/packages/fcl-db/tests/toolsunit.pas

fcl-db: tests: move IFDEF to proper position
r23190 | reiniero | 2012-12-19 14:11:47 +0100 (Wed, 19 Dec 2012) | 3 lines
Changed paths:
M /trunk/packages/fcl-db/src/dbase/dbf.pas

* FCL-DB: only honour lopartialkey for locate on indexed fields if field is string type.
This aligns behaviour with non-indexed locate as well as fpc bufdataset.
Partly addresses issue #23509
r23191 | reiniero | 2012-12-19 14:21:22 +0100 (Wed, 19 Dec 2012) | 1 line
Changed paths:
D /trunk/packages/fcl-db/tests/dbfexporttestcase1.pas

- FCL-DB: db test framework: clean up dbf export code (duplicate functionality since r23164)
r23192 | reiniero | 2012-12-19 16:58:58 +0100 (Wed, 19 Dec 2012) | 1 line
Changed paths:
M /trunk/packages/fcl-db/tests/testdbbasics.pas

+ FCL-DB: db test framework: add test for issue #23509: locate must ignore lopartialkey for non-string fields
r23198 | lacak | 2012-12-21 07:49:27 +0100 (Fri, 21 Dec 2012) | 2 lines
Changed paths:
M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp
M /trunk/packages/fcl-db/tests/testfieldtypes.pas

fcl-db: postgresql: increase max allowed string field length. Fix for existing test TTestFieldTypes.TestStringLargerThen8192.
(using MaxSamllint is inspired by Delphi dbExpress, where my tests shows, that max supported length is 32767 if used char/varchar with length above this limit various errors appears like "Invalid field size")
r23200 | lacak | 2012-12-21 13:48:32 +0100 (Fri, 21 Dec 2012) | 1 line
Changed paths:
M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

fcl-db: postgresql: catalog_name for GetSchemaInfoSQL
r23228 | ludob | 2012-12-27 19:09:22 +0100 (Thu, 27 Dec 2012) | 1 line
Changed paths:
M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

pqconnection.pp: use of connection pool instead of creating a new connection for every new transaction.
r23307 | lacak | 2013-01-04 08:38:02 +0100 (Fri, 04 Jan 2013) | 5 lines
Changed paths:
M /trunk/packages/fcl-db/src/base/bufdataset.pas
M /trunk/packages/fcl-db/src/base/dataset.inc
M /trunk/packages/fcl-db/tests/testdbbasics.pas

fcl-db:
* Fixes tests for UniDirectional datasets
* Calculated fields are supported by UniDirectional datasets
* Lookup fields return always null for UniDirectional datasets in Delphi
* First is valid for UniDirectional datasets (in TDataSet.First closes/opens dataset if not at Bof)
r23439 | michael | 2013-01-18 15:42:13 +0100 (Fri, 18 Jan 2013) | 5 lines
Changed paths:
M /trunk/packages/fcl-db/src/codegen/fpddcodegen.pp

* Added possibility to force use of setter/getter for properties.
* Added possibility to add a line of text in the property setter. (%PROPNAME%)
* Fixed TCodeOptions.Assign, missing a couple of properties.
* Fixed name of setter routine
r23440 | michael | 2013-01-18 15:43:34 +0100 (Fri, 18 Jan 2013) | 3 lines
Changed paths:
M /trunk/packages/fcl-db/src/codegen/fpcgtiopf.pp

* Enable property setter by default
* Fixed index in list class
r23445 | michael | 2013-01-18 17:38:04 +0100 (Fri, 18 Jan 2013) | 1 line
Changed paths:
M /trunk/packages/fcl-db/src/sqldb/postgres/pqconnection.pp

* Corrected statements for tables and system tables
r23455 | michael | 2013-01-20 12:25:28 +0100 (Sun, 20 Jan 2013) | 1 line
Changed paths:
M /trunk/packages/fcl-db/src/sqldb/sqldb.pp

* Notification should be protected

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

marco 12 years ago
parent
commit
059f69fb42

+ 0 - 1
.gitattributes

@@ -2008,7 +2008,6 @@ packages/fcl-db/tests/Makefile.fpc -text
 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/dbfexporttestcase1.pas svneol=native#text/plain
 packages/fcl-db/tests/dbftoolsunit.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

+ 4 - 5
packages/fcl-db/src/base/bufdataset.pas

@@ -1233,11 +1233,9 @@ end;
 procedure TCustomBufDataset.InternalFirst;
 begin
   with FCurrentIndex do
-    begin
-// if FCurrentRecBuf = FLastRecBuf then the dataset is just opened and empty
-// in which case InternalFirst should do nothing (bug 7211)
+    // if FCurrentRecBuf = FLastRecBuf then the dataset is just opened and empty
+    // in which case InternalFirst should do nothing (bug 7211)
     SetToFirstRecord;
-    end;
 end;
 
 procedure TCustomBufDataset.InternalLast;
@@ -3609,7 +3607,8 @@ end;
 
 procedure TUniDirectionalBufIndex.SetToFirstRecord;
 begin
-  DatabaseError(SUniDirectional);
+  // for UniDirectional datasets should be [Internal]First valid method call
+  // do nothing
 end;
 
 procedure TUniDirectionalBufIndex.SetToLastRecord;

+ 5 - 4
packages/fcl-db/src/base/dataset.inc

@@ -139,15 +139,16 @@ var
   OldState: TDatasetState;
 begin
   FCalcBuffer := Buffer; 
-  if not IsUniDirectional and (FState <> dsInternalCalc) then
+  if FState <> dsInternalCalc then
   begin
     OldState := FState;
     FState := dsCalcFields;
     try
       ClearCalcFields(FCalcBuffer);
-      for i := 0 to FFieldList.Count - 1 do
-        if FFieldList[i].FieldKind = fkLookup then
-          FFieldList[i].CalcLookupValue;
+      if not IsUniDirectional then
+        for i := 0 to FFieldList.Count - 1 do
+          if FFieldList[i].FieldKind = fkLookup then
+            FFieldList[i].CalcLookupValue;
     finally
       DoOnCalcFields;
       FState := OldState;

+ 23 - 3
packages/fcl-db/src/codegen/fpcgtiopf.pp

@@ -30,7 +30,13 @@ TYpe
   TVisitorOption = (voRead,voReadList,voCreate,voDelete,voUpdate,
                     voCommonSetupParams,voSingleSaveVisitor,voRegisterVisitors);
   TVisitorOptions = set of TVisitorOption;
-  
+
+  { TTiOPFFieldPropDef }
+
+  TTiOPFFieldPropDef = Class(TFieldPropDef)
+  Public
+    Constructor Create(ACollection : TCollection); override;
+  end;
   { TTiOPFCodeOptions }
 
   TTiOPFCodeOptions = Class (TClassCodeGeneratorOptions)
@@ -100,6 +106,7 @@ TYpe
     // Not to be overridden.
     procedure WriteListAddObject(Strings: TStrings; const ListClassName, ObjectClassName: String);
     // Overrides of parent objects
+    Function CreateFieldPropDefs : TFieldPropDefs; override;
     function AllowPropertyDeclaration(F: TFieldPropDef; AVisibility: TVisibilities): Boolean; override;
     Function GetInterfaceUsesClause : string; override;
     procedure WriteVisibilityStart(V: TVisibility; Strings: TStrings); override;
@@ -134,6 +141,14 @@ begin
     Delete(Result,1,1);
 end;
 
+{ TTiOPFFieldPropDef }
+
+constructor TTiOPFFieldPropDef.Create(ACollection: TCollection);
+begin
+  inherited Create(ACollection);
+  PropSetters:=[psWrite];
+end;
+
 { TTiOPFCodeOptions }
 
 function TTiOPFCodeOptions.GetListClassName: String;
@@ -872,7 +887,7 @@ begin
       ptSingle, ptDouble, ptExtended, ptComp :
         S:='AsFloat';
       ptCurrency :
-        S:='AsCurrency';
+        S:='AsFloat';
       ptDateTime :
         S:='AsDateTime';
       ptEnumerated :
@@ -1139,7 +1154,7 @@ begin
       AddLn(Strings,'Public');
     IncIndent;
     Try
-      AddLn(Strings,'Property Items[Index : Integer] : %s Read GetObj Write SetObj; Default;',[ObjectClassname]);
+      AddLn(Strings,'Property Items[AIndex : Integer] : %s Read GetObj Write SetObj; Default;',[ObjectClassname]);
     Finally
       DecIndent;
     end;
@@ -1178,6 +1193,11 @@ begin
    Addln(Strings);
 end;
 
+function TTiOPFCodeGenerator.CreateFieldPropDefs: TFieldPropDefs;
+begin
+  Result:=TFieldPropDefs.Create(TTiOPFFieldPropDef);
+end;
+
 function TTiOPFCodeGenerator.AllowPropertyDeclaration(F: TFieldPropDef;
   AVisibility: TVisibilities): Boolean;
 begin

+ 33 - 8
packages/fcl-db/src/codegen/fpddcodegen.pp

@@ -38,6 +38,8 @@ Type
   TVisibility = (vPrivate,vProtected,vPublic,vPublished);
   TVisibilities = Set of TVisibility;
   TPropAccess = (paReadWrite,paReadonly,paWriteonly);
+  TPropSetter = (psRead,psWrite);
+  TPropSetters = set of TPropSetter;
 
 
   TFieldPropDefs = Class;
@@ -51,6 +53,7 @@ Type
     FFieldType: TFieldType;
     FPropAccess: TPropAccess;
     FPropDef: String;
+    FPropSetters: TPropSetters;
     FPropType : TPropType;
     FPRopSize: Integer;
     FPropName : String;
@@ -66,8 +69,8 @@ Type
     Constructor Create(ACollection : TCollection) ; override;
     Procedure Assign(ASource : TPersistent); override;
     Function FieldPropDefs : TFieldPropDefs;
-    Function HasGetter : Boolean; Virtual; // Always false.
-    Function HasSetter : Boolean; Virtual; // True for streams/strings
+    Function HasGetter : Boolean; Virtual; // Checks Propsetters for psRead
+    Function HasSetter : Boolean; Virtual; // True for streams/strings or if Propsetters has pswrite
     Function ObjPasTypeDef : String; virtual; // Object pascal definition of type
     Function ObjPasReadDef : String; virtual; // Object pascal definition of getter
     Function ObjPasWriteDef : String; virtual; // Object pascal definition of setter
@@ -81,6 +84,7 @@ Type
     Property PropertyDef : String Read FPropDef Write FPropDef;
     Property PropertyVisibility : TVisibility Read FPropVis Write FPropVis;
     Property PropertyAccess : TPropAccess Read FPropAccess Write FPropAccess;
+    Property PropSetters : TPropSetters Read FPropSetters Write FPropSetters;
   end;
   
   { TFieldPropDefs }
@@ -113,6 +117,7 @@ Type
     FInterfaceUnits: String;
     FOptions: TCodeOptions;
     FUnitName: String;
+    FExtraSetterLine : string;
     procedure SetImplementationUnits(const AValue: String);
     procedure SetInterfaceUnits(const AValue: String);
     procedure SetUnitname(const AValue: String);
@@ -122,9 +127,15 @@ Type
     Constructor create; virtual;
     Procedure Assign(ASource : TPersistent); override;
   Published
+    // Line of code that will be added to each property setter. Use %PROPNAME% to include property name in the line.
+    Property ExtraSetterLine : String Read FExtraSetterLine Write FExtraSetterLine;
+    // options
     Property Options : TCodeOptions Read FOptions Write SetOPtions;
+    // Name of unit if a unit is generated.
     Property UnitName : String Read FUnitName Write SetUnitname;
+    // Comma-separated list of  units that will be put in the interface units clause
     Property InterfaceUnits : String Read FInterfaceUnits Write SetInterfaceUnits;
+    //  Comma-separated list of  units that will be put in the implementation units clause
     Property ImplementationUnits : String Read FImplementationUnits Write SetImplementationUnits;
   end;
   TCodeGeneratorOptionsClass = Class of TCodeGeneratorOptions;
@@ -539,13 +550,13 @@ end;
 
 function TFieldPropDef.HasGetter: Boolean;
 begin
-  Result:=False;
+  Result:=psRead in PropSetters;
 end;
 
 function TFieldPropDef.HasSetter: Boolean;
 begin
   Result:=(PropertyAccess in [paReadWrite,paWriteOnly])
-          and (PropertyType in [ptStream,ptTStrings]);
+          and ((PropertyType in [ptStream,ptTStrings]) or (psWrite in Propsetters));
 end;
 
 function TFieldPropDef.ObjPasTypeDef: String;
@@ -832,7 +843,7 @@ begin
   For I:=0 to Fields.Count-1 do
     begin
     F:=Fields[i];
-    if AllowPropertyDeclaration(F,[]) and F.HasGetter then
+    if AllowPropertyDeclaration(F,[]) and F.HasSetter then
       begin
       If not B then
         begin
@@ -867,22 +878,33 @@ Procedure TDDClassCodeGenerator.WritePropertySetterImpl(Strings : TStrings; F :
 
 Var
   S : String;
+  L : Integer;
 
 begin
-  S:=PropertyGetterDeclaration(F,True);
+  S:=PropertySetterDeclaration(F,True);
   BeginMethod(Strings,S);
   AddLn(Strings,'begin');
   IncIndent;
   Try
+    AddLn(Strings,Format('if (F%s=AValue) then exit;',[F.PropertyName]));
     Case F.PropertyType of
       ptTStrings :
         S:=Format('F%s.Assign(AValue);',[F.PropertyName]);
       ptStream :
         S:=Format('F%s.CopyFrom(AValue,0);',[F.PropertyName]);
     else
-       S:=Format('F%s:=AValue',[F.PropertyName]);
+       S:=Format('F%s:=AValue;',[F.PropertyName]);
     end;
     AddLn(Strings,S);
+    S:=CodeOptions.ExtraSetterLine;
+    L:=Length(S);
+    if (L>0) then
+      begin
+      S:=StringReplace(S,'%PROPNAME%',F.PropertyName,[rfReplaceAll,rfIgnoreCase]);
+      if (S[L]<>';') then
+        S:=S+';';
+      AddLn(Strings,S);  
+      end;
   Finally
     DecIndent;
   end;
@@ -1093,7 +1115,7 @@ begin
   Result:='Procedure ';
   If Impl then
     Result:=Result+ClassOptions.ObjectClassName+'.';
-  Result:=Result+Def.ObjPasReadDef+' (AValue  : '+Def.ObjPasTypeDef+');';
+  Result:=Result+Def.ObjPasWriteDef+' (AValue  : '+Def.ObjPasTypeDef+');';
 end;
 
 function TDDClassCodeGenerator.NeedsConstructor: Boolean;
@@ -1478,8 +1500,11 @@ begin
   If ASource is TCodeGeneratorOptions then
     begin
     CG:=ASource as TCodeGeneratorOptions;
+    FInterfaceUnits:=CG.InterfaceUnits;
+    FImplementationUnits:=CG.ImplementationUnits;
     FOptions:=CG.FOptions;
     FUnitName:=CG.UnitName;
+    FExtraSetterLine:=CG.ExtraSetterLine;
     end
   else
     inherited Assign(ASource);

+ 6 - 2
packages/fcl-db/src/dbase/dbf.pas

@@ -1758,7 +1758,7 @@ var
   var
     sCompare: String;
   begin
-    if (Field.DataType = ftString) then
+    if (Field.DataType in [ftString,ftWideString]) then
     begin
       sCompare := VarToStr(varCompare);
       if loCaseInsensitive in Options then
@@ -1785,6 +1785,8 @@ var
       end;
     end
     else
+      // Not a string; could be date, integer etc.
+      // Follow e.g. FPC bufdataset by searching for equal  
       Result := Field.Value = varCompare;
   end;
 
@@ -1848,7 +1850,9 @@ var
   lTempBuffer: array [0..100] of Char;
   acceptable, checkmatch: boolean;
 begin
-  if loPartialKey in Options then
+  // Only honor loPartialKey for string types; for others, search for equal
+  if (loPartialKey in Options) and
+    (TIndexCursor(FCursor).IndexFile.KeyType='C') then
     searchFlag := stGreaterEqual
   else
     searchFlag := stEqual;

+ 185 - 108
packages/fcl-db/src/sqldb/postgres/pqconnection.pp

@@ -18,7 +18,6 @@ type
   TPQTrans = Class(TSQLHandle)
     protected
     PGConn        : PPGConn;
-    ErrorOccured  : boolean;
   end;
 
   TPQCursor = Class(TSQLCursor)
@@ -41,16 +40,22 @@ type
       STATEMENT_POSITION:string;
   end;
 
+  TTranConnection= class
+  protected
+    FPGConn        : PPGConn;
+    FTranActive    : boolean
+  end;
+
   { TPQConnection }
 
   TPQConnection = class (TSQLConnection)
   private
+    FConnectionPool      : array of TTranConnection;
     FCursorCount         : word;
     FConnectString       : string;
     FSQLDatabaseHandle   : pointer;
     FIntegerDateTimes    : boolean;
     procedure CheckResultError(var res: PPGresult; conn:PPGconn; ErrMsg: string);
-    function GetPQDatabaseError(res : PPGresult;ErrMsg: string):EPQDatabaseError;
     function TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer) : TFieldType;
     procedure ExecuteDirectPG(const Query : String);
   protected
@@ -215,6 +220,7 @@ function TPQConnection.RollBack(trans : TSQLHandle) : boolean;
 var
   res : PPGresult;
   tr  : TPQTrans;
+  i   : Integer;
 begin
   result := false;
 
@@ -225,7 +231,13 @@ begin
   CheckResultError(res,tr.PGConn,SErrRollbackFailed);
 
   PQclear(res);
-  PQFinish(tr.PGConn);
+  //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;
   result := true;
 end;
 
@@ -233,6 +245,7 @@ function TPQConnection.Commit(trans : TSQLHandle) : boolean;
 var
   res : PPGresult;
   tr  : TPQTrans;
+  i   : Integer;
 begin
   result := false;
 
@@ -242,7 +255,13 @@ begin
   CheckResultError(res,tr.PGConn,SErrCommitFailed);
 
   PQclear(res);
-  PQFinish(tr.PGConn);
+  //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;
   result := true;
 end;
 
@@ -250,30 +269,48 @@ function TPQConnection.StartdbTransaction(trans : TSQLHandle; AParams : string)
 var
   res : PPGresult;
   tr  : TPQTrans;
+  i   : Integer;
 begin
+  result:=false;
   tr := trans as TPQTrans;
 
-  tr.PGConn := PQconnectdb(pchar(FConnectString));
-
-  if (PQstatus(tr.PGConn) = CONNECTION_BAD) then
+  //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
+      i:=i+1;
+  if i=length(FConnectionPool) then //create a new connection
     begin
-    result := false;
-    PQFinish(tr.PGConn);
-    DatabaseError(SErrConnectionFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self);
+    tr.PGConn := PQconnectdb(pchar(FConnectString));
+    if (PQstatus(tr.PGConn) = CONNECTION_BAD) then
+      begin
+      result := false;
+      PQFinish(tr.PGConn);
+      DatabaseError(SErrConnectionFailed + ' (PostgreSQL: ' + PQerrorMessage(tr.PGConn) + ')',self);
+      end
+    else
+      begin
+      if CharSet <> '' then
+        PQsetClientEncoding(tr.PGConn, pchar(CharSet));
+      //store the new connection
+      SetLength(FConnectionPool,i+1);
+      FConnectionPool[i]:=TTranConnection.Create;
+      FConnectionPool[i].FPGConn:=tr.PGConn;
+      FConnectionPool[i].FTranActive:=true;
+      end;
     end
-  else
+  else //re-use existing connection
     begin
-    tr.ErrorOccured := False;
-
-    if CharSet <> '' then
-      PQsetClientEncoding(tr.PGConn, pchar(CharSet));
-
-    res := PQexec(tr.PGConn, 'BEGIN');
-    CheckResultError(res,tr.PGConn,sErrTransactionFailed);
-
-    PQclear(res);
-    result := true;
+    tr.PGConn:=FConnectionPool[i].FPGConn;
+    FConnectionPool[i].FTranActive:=true;
     end;
+  res := PQexec(tr.PGConn, 'BEGIN');
+  CheckResultError(res,tr.PGConn,sErrTransactionFailed);
+
+  PQclear(res);
+  result := true;
 end;
 
 procedure TPQConnection.RollBackRetaining(trans : TSQLHandle);
@@ -338,71 +375,83 @@ 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(FSQLDatabaseHandle,'integer_datetimes') = 'on';
+  SetLength(FConnectionPool,1);
+  FConnectionPool[0]:=TTranConnection.Create;
+  FConnectionPool[0].FPGConn:=FSQLDatabaseHandle;
+  FConnectionPool[0].FTranActive:=false;
 end;
 
 procedure TPQConnection.DoInternalDisconnect;
+var i:integer;
 begin
-  PQfinish(FSQLDatabaseHandle);
+  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);
 {$IfDef LinkDynamically}
   ReleasePostgres3;
 {$EndIf}
-
 end;
 
 procedure TPQConnection.CheckResultError(var res: PPGresult; conn: PPGconn;
   ErrMsg: string);
 var
   E: EPQDatabaseError;
-
+  sErr: string;
+  CompName: string;
+  SEVERITY: string;
+  SQLSTATE: string;
+  MESSAGE_PRIMARY: string;
+  MESSAGE_DETAIL: string;
+  MESSAGE_HINT: string;
+  STATEMENT_POSITION: string;
+  i:Integer;
 begin
   if (PQresultStatus(res) <> PGRES_COMMAND_OK) then
     begin
-    E:=GetPQDatabaseError(res,ErrMsg);
+    SEVERITY:=PQresultErrorField(res,ord('S'));
+    SQLSTATE:=PQresultErrorField(res,ord('C'));
+    MESSAGE_PRIMARY:=PQresultErrorField(res,ord('M'));
+    MESSAGE_DETAIL:=PQresultErrorField(res,ord('D'));
+    MESSAGE_HINT:=PQresultErrorField(res,ord('H'));
+    STATEMENT_POSITION:=PQresultErrorField(res,ord('P'));
+    sErr:=PQresultErrorMessage(res)+
+      'Severity: '+ SEVERITY +LineEnding+
+      'SQL State: '+ SQLSTATE +LineEnding+
+      'Primary Error: '+ MESSAGE_PRIMARY +LineEnding+
+      'Error Detail: '+ MESSAGE_DETAIL +LineEnding+
+      'Hint: '+ MESSAGE_HINT +LineEnding+
+      'Character: '+ STATEMENT_POSITION +LineEnding;
+    if Self.Name = '' then CompName := Self.ClassName else CompName := Self.Name;
+    E:=EPQDatabaseError.CreateFmt('%s : %s  (PostgreSQL: %s)', [CompName, ErrMsg, sErr]);
+    E.SEVERITY:=SEVERITY;
+    E.SQLSTATE:=SQLSTATE;
+    E.MESSAGE_PRIMARY:=MESSAGE_PRIMARY;
+    E.MESSAGE_DETAIL:=MESSAGE_DETAIL;
+    E.MESSAGE_HINT:=MESSAGE_HINT;
+    E.STATEMENT_POSITION:=STATEMENT_POSITION;
+
     PQclear(res);
     res:=nil;
     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;
+      end;
     raise E;
     end;
 end;
 
-function TPQConnection.GetPQDatabaseError(res: PPGresult; ErrMsg: string
-  ): EPQDatabaseError;
-var
-  serr:string;
-  E: EPQDatabaseError;
-  CompName: string;
-  SEVERITY:string;
-  SQLSTATE: string;
-  MESSAGE_PRIMARY:string;
-  MESSAGE_DETAIL:string;
-  MESSAGE_HINT:string;
-  STATEMENT_POSITION:string;
-begin
-  SEVERITY:=PQresultErrorField(res,ord('S'));
-  SQLSTATE:=PQresultErrorField(res,ord('C'));
-  MESSAGE_PRIMARY:=PQresultErrorField(res,ord('M'));
-  MESSAGE_DETAIL:=PQresultErrorField(res,ord('D'));
-  MESSAGE_HINT:=PQresultErrorField(res,ord('H'));
-  STATEMENT_POSITION:=PQresultErrorField(res,ord('P'));
-  serr:=PQresultErrorMessage(res)+LineEnding+
-    'Severity: '+ SEVERITY +LineEnding+
-    'SQL State: '+ SQLSTATE +LineEnding+
-    'Primary Error: '+ MESSAGE_PRIMARY +LineEnding+
-    'Error Detail: '+ MESSAGE_DETAIL +LineEnding+
-    'Hint: '+ MESSAGE_HINT +LineEnding+
-    'Character: '+ STATEMENT_POSITION +LineEnding;
-  if Self.Name = '' then CompName := Self.ClassName else CompName := Self.Name;
-  E:=EPQDatabaseError.CreateFmt('%s : %s  (PostgreSQL: %s)', [CompName,ErrMsg, serr]);
-  E.SEVERITY:=SEVERITY;
-  E.SQLSTATE:=SQLSTATE;
-  E.MESSAGE_PRIMARY:=MESSAGE_PRIMARY;
-  E.MESSAGE_DETAIL:=MESSAGE_DETAIL;
-  E.MESSAGE_HINT:=MESSAGE_HINT;
-  E.STATEMENT_POSITION:=STATEMENT_POSITION;
-  result:=E;
-end;
-
 function TPQConnection.TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer) : TFieldType;
 const VARHDRSZ=sizeof(longint);
 var li : longint;
@@ -421,7 +470,7 @@ begin
                                else
                                  size := (li-VARHDRSZ) and $FFFF;
                                end;
-                             if size > dsMaxStringSize then size := dsMaxStringSize;
+                             if size > MaxSmallint then size := MaxSmallint;
                              end;
 //    Oid_text               : Result := ftstring;
     Oid_text               : Result := ftMemo;
@@ -599,7 +648,7 @@ begin
     res:=nil;
     if FPrepared then
       begin
-      if not tr.ErrorOccured then
+      if PQtransactionStatus(tr.PGConn) <> PQTRANS_INERROR then
         begin
         res := PQexec(tr.PGConn,pchar('deallocate '+StmtName));
         CheckResultError(res,nil,SErrUnPrepareFailed);
@@ -699,10 +748,9 @@ begin
 
     if assigned(res) and not (PQresultStatus(res) in [PGRES_COMMAND_OK,PGRES_TUPLES_OK]) then
       begin
-      tr.ErrorOccured := True;
-// Don't perform the rollback, only make it possible to do a rollback.
-// The other databases also don't do this.
-//      atransaction.Rollback;
+      // Don't perform the rollback, only make it possible to do a rollback.
+      // The other databases also don't do this.
+      //atransaction.Rollback;
       CheckResultError(res,nil,SErrExecuteFailed);
       end;
 
@@ -734,8 +782,36 @@ begin
 end;
 
 function TPQConnection.GetHandle: pointer;
+var
+  i:integer;
 begin
-  Result := FSQLDatabaseHandle;
+  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
+      begin
+      Result :=FConnectionPool[i].FPGConn;
+      exit;
+      end;
+  //Nothing connected!! Reconnect
+  if assigned(FConnectionPool[0].FPGConn) then
+    PQreset(FConnectionPool[0].FPGConn)
+  else
+    FConnectionPool[0].FPGConn := PQconnectdb(pchar(FConnectString));
+  if (PQstatus(FConnectionPool[0].FPGConn) = CONNECTION_BAD) then
+    begin
+    result := nil;
+    PQFinish(FConnectionPool[0].FPGConn);
+    FConnectionPool[0].FPGConn:=nil;
+    FConnectionPool[0].FTranActive:=false;
+    DatabaseError(SErrConnectionFailed + ' (PostgreSQL: ' + PQerrorMessage(FConnectionPool[0].FPGConn) + ')',self);
+    end
+  else
+    if CharSet <> '' then
+      PQsetClientEncoding(FConnectionPool[0].FPGConn, pchar(CharSet));
+  result:=FConnectionPool[0].FPGConn;
 end;
 
 function TPQConnection.Fetch(cursor : TSQLCursor) : boolean;
@@ -850,7 +926,7 @@ begin
             else
             begin
               li := pqgetlength(res,curtuple,x);
-              if li > dsMaxStringSize then li := dsMaxStringSize;
+              if li > FieldDef.Size then li := FieldDef.Size;
               Move(CurrBuff^, Buffer^, li);
             end;
           end;
@@ -1001,50 +1077,51 @@ function TPQConnection.GetSchemaInfoSQL(SchemaType: TSchemaType;
 var s : string;
 
 begin
+  // select * from information_schema.tables with 
+  // where table_schema [not] in ('pg_catalog','information_schema') may be better.
+  // But the following should work:
   case SchemaType of
     stTables     : s := 'select '+
-                          'relfilenode              as recno, '+
-                          '''' + DatabaseName + ''' as catalog_name, '+
-                          'nspname                  as schema_name, '+
-                          'relname                  as table_name, '+
-                          '0                        as table_type '+
-                        'from '+
-                          'pg_class c left join pg_namespace n on c.relnamespace=n.oid '+
-                        'where '+
-                          'relkind=''r''' +
+                          'relfilenode        as recno, '+
+                          'current_database() as catalog_name, '+
+                          'nspname            as schema_name, '+
+                          'relname            as table_name, '+
+                          '0                  as table_type '+
+                        'from pg_class c '+
+                          'left join pg_namespace n on c.relnamespace=n.oid '+
+                        'where (relkind=''r'') and not (nspname in (''pg_catalog'',''information_schema''))' +
                         'order by relname';
 
     stSysTables  : s := 'select '+
-                          'relfilenode              as recno, '+
-                          '''' + DatabaseName + ''' as catalog_name, '+
-                          'nspname                  as schema_name, '+
-                          'relname                  as table_name, '+
-                          '0                        as table_type '+
-                        'from '+
-                          'pg_class c left join pg_namespace n on c.relnamespace=n.oid '+
-                        'where '+
-                          'relkind=''r'' and nspname=''pg_catalog'' ' + // only system tables
+                          'relfilenode        as recno, '+
+                          'current_database() as catalog_name, '+
+                          'nspname            as schema_name, '+
+                          'relname            as table_name, '+
+                          '0                  as table_type '+
+                        'from pg_class c '+
+                          'left join pg_namespace n on c.relnamespace=n.oid '+
+                        'where (relkind=''r'') and nspname in ((''pg_catalog'',''information_schema'')) ' + // only system tables
                         'order by relname';
     stColumns    : s := 'select '+
-                          'a.attnum                 as recno, '+
-                          '''''                     as catalog_name, '+
-                          '''''                     as schema_name, '+
-                          'c.relname                as table_name, '+
-                          'a.attname                as column_name, '+
-                          '0                        as column_position, '+
-                          '0                        as column_type, '+
-                          '0                        as column_datatype, '+
-                          '''''                     as column_typename, '+
-                          '0                        as column_subtype, '+
-                          '0                        as column_precision, '+
-                          '0                        as column_scale, '+
-                          'a.atttypmod              as column_length, '+
-                          'not a.attnotnull         as column_nullable '+
-                        'from '+
-                          ' pg_class c, pg_attribute a '+
-                        'WHERE '+
-                        // This can lead to problems when case-sensitive tablenames are used.
-                          '(c.oid=a.attrelid) and (a.attnum>0) and (not a.attisdropped) and (upper(c.relname)=''' + Uppercase(SchemaObjectName) + ''') ' +
+                          'a.attnum           as recno, '+
+                          'current_database() as catalog_name, '+
+                          'nspname            as schema_name, '+
+                          'c.relname          as table_name, '+
+                          'a.attname          as column_name, '+
+                          '0                  as column_position, '+
+                          '0                  as column_type, '+
+                          '0                  as column_datatype, '+
+                          '''''               as column_typename, '+
+                          '0                  as column_subtype, '+
+                          '0                  as column_precision, '+
+                          '0                  as column_scale, '+
+                          'a.atttypmod        as column_length, '+
+                          'not a.attnotnull   as column_nullable '+
+                        'from pg_class c '+
+                          'join pg_attribute a on c.oid=a.attrelid '+
+                          'left join pg_namespace n on c.relnamespace=n.oid '+
+                          // This can lead to problems when case-sensitive tablenames are used.
+                        'where (a.attnum>0) and (not a.attisdropped) and (upper(c.relname)=''' + Uppercase(SchemaObjectName) + ''') '+
                         'order by a.attname';
   else
     DatabaseError(SMetadataUnavailable)
@@ -1089,7 +1166,7 @@ begin
       citServerVersion,
       citServerVersionString:
         if Connected then
-          Result:=format('%6.6d', [PQserverVersion(FSQLDatabaseHandle)]);
+          Result:=format('%6.6d', [PQserverVersion(GetHandle)]);
       citClientName:
         Result:=TPQConnectionDef.LoadedLibraryName;
     else

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

@@ -278,6 +278,7 @@ type
     procedure SetReadOnly(AValue : Boolean); override;
     Function LogEvent(EventType : TDBEventType) : Boolean;
     Procedure Log(EventType : TDBEventType; Const Msg : String); virtual;
+    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
   public
     procedure Prepare; virtual;
     procedure UnPrepare; virtual;
@@ -286,7 +287,6 @@ type
     destructor Destroy; override;
     procedure SetSchemaInfo( ASchemaType : TSchemaType; ASchemaObjectName, ASchemaPattern : string); virtual;
     property Prepared : boolean read IsPrepared;
-    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
     function RowsAffected: TRowsCount; virtual;
     function ParamByName(Const AParamName : String) : TParam;
   protected

+ 0 - 495
packages/fcl-db/tests/dbfexporttestcase1.pas

@@ -1,495 +0,0 @@
-unit dbfexporttestcase1;
-
-{$mode objfpc}{$H+}
-
-interface
-
-uses
-  Classes, SysUtils, Fpcunit, Testutils, Testregistry, DB, fpdbfexport,
-  BufDataset, dateutils;
-
-type
-
-  { TTestDBFExport1 }
-
-  TTestDBFExport1 = class(Ttestcase)
-  const
-    KeepFilesAfterTest = false;
-    //Change if you want to keep export files for further testing
-  private
-    procedure FillTestData;
-  protected
-    FTestDataset: TBufDataset;
-    FExportTempDir: string; //where we store exported files in these tests
-    procedure FillRecord(const RowNumber: integer; const Teststring: string;
-      const TestGUID: string; const TestInteger: integer;
-      const TestExtended: extended; const TestDatetime: Tdatetime;
-      const TestBoolean: boolean);
-    procedure Setup; override;
-    procedure Teardown; override;
-  published
-    procedure TestDBExportRuns;
-  end;
-
-implementation
-
-function FileSize(FileName: string): integer;
-  // LCL has similar function, but we don't want to depend on that.
-var
-  SearchResult: TSearchRec;
-begin
-  Result := 0;
-  if FindFirst(FileName, faAnyFile, SearchResult) = 0 then
-  begin
-    try
-      Result := SearchResult.Size;
-    finally
-      FindClose(SearchResult);
-    end;
-  end;
-end;
-
-procedure TTestDBFExport1.TestDBExportRuns;
-
-var
-  Export: TFPDBFExport;
-  ExportSettings: TDBFExportFormatSettings;
-  NumberExported: integer;
-begin
-  Export := TFPDBFExport.Create(nil);
-  ExportSettings:=TDBFExportFormatSettings.Create(true);
-  try
-    //Don't override decimal separator
-    ExportSettings.TableFormat:=tfDBaseVII; //dbase IV seems to have a 10 character field name limit
-    Export.FormatSettings:=ExportSettings;
-    Export.Dataset := FTestDataset;
-    Export.FileName := FExportTempDir + 'dbfexporttest.dbf';
-    NumberExported := Export.Execute;
-    FTestDataset.Close;
-    AssertEquals('Number of records exported', NumberExported, FTestDataset.RecordCount);
-    AssertTrue('Output file created', FileExists(Export.FileName));
-    AssertTrue('Output file has contents', (FileSize(Export.FileName) > 0));
-  finally
-    if (KeepFilesAfterTest = False) then
-    begin
-      DeleteFile(Export.FileName);
-    end;
-    ExportSettings.Free;
-    Export.Free;
-  end;
-end;
-
-
-procedure TTestDBFExport1.FillTestData;
-var
-  RowNumber: integer; //Keep track of how many rows we inserted
-  TestBoolean: boolean;
-  TestDateTime: TDateTime;
-  TestExtended: extended;
-  //yes, a lot of precision; we can convert to single/double if required
-  TestInteger: integer;
-  TestGuid: string;
-  TestString: string;
-begin
-  FTestDataset.Close;
-  RowNumber := 0;
-  //for memds:
-  //FTestDataset.Clear(False); //memds: clear out any data
-  //FTestDataset.Fields.Clear; //bufds: clear out any data, but also FIELDDEFS: don't use
-  FTestDataset.Open;
-
-  // Fill some test data
-  // First row: positive numerical values, late dates/times, strings with special chars (tab, linefeed, ; > <)
-  FTestDataset.Append;
-  TestBoolean := True;
-  TestDateTime := EncodeDate(9999, 12, 31) + EncodeTime(23, 59, 59, 999);
-  TestExtended := 42.424242424242424242424242424242;
-  TestInteger := Round(TestExtended);
-  TestGuid := '{21EC2020-3AEA-1069-A2DD-08002B30309D}';
-  TestString := 'Douglas Adams less than: < greater than > tab:' +
-    #9 + 'crlf:' + #13 + #10 +
-    '國缺界广欠廣界界东缺. Haddock drinks rosé (ros, e accent aigu), водка (wodka cyrillic) and ούζο (ouzo Greek) but prefers Loch Lomond whiskey.';
-  RowNumber := RowNumber + 1;
-  FillRecord(RowNumber, Teststring, TestGUID, Testinteger, Testextended,
-    Testdatetime, Testboolean);
-  FTestDataset.Post;
-
-  // Second row: negative numerical values, early dates/times, strings with maximum field width and Greek, east asian (multibyte) characters
-  FTestDataset.Append;
-  TestBoolean := False;
-  TestDateTime := EncodeDate(1, 1, 1) + EncodeTime(0, 0, 0, 1);
-  TestExtended := -42.424242424242424242424242424242;
-  TestInteger := Round(TestExtended);
-  TestGuid := '{FFFFFFFF-FFFF-FFFF-FFFF-FFFFFFFFFFFF}';
-  TestString := 'ARMA virumque cano, Troiae qui primus ab oris' +
-    #13 + #10 + 'Italiam, fato profugus, Laviniaque venit' + #13 +
-    #10 + 'litora, multum ille et terris iactatus et alto' + #13 +
-    #10 + 'vi superum saevae memorem Iunonis ob iram;' + #13 + #10 +
-    'multa quoque et bello passus, dum conderet urbem,' + #13 + #10 +
-    'inferretque deos Latio, genus unde Latinum,' + #13 + #10 +
-    'Albanique patres, atque altae moenia Romae.' + #13 + #10 + #13 +
-    #10 + 'Musa, mihi causas memora, quo numine laeso,' + #13 + #10 +
-    'quidve dolens, regina deum tot volvere casus' + #13 + #10 +
-    'insignem pietate virum, tot adire labores' + #13 + #10 +
-    'impulerit.  Tantaene animis caelestibus irae?' + #13 + #10 +
-    #13 + #10 + 'Urbs antiqua fuit, Tyrii tenuere coloni,' + #13 +
-    #10 + 'Karthago, Italiam contra Tiberinaque longe' + #13 + #10 +
-    'ostia, dives opum studiisque asperrima belli;' + #13 + #10 +
-    'quam Iuno fertur terris magis omnibus unam' + #13 + #10 +
-    'posthabita coluisse Samo; hic illius arma,' + #13 + #10 +
-    'hic currus fuit; hoc regnum dea gentibus esse,' + #13 + #10 +
-    'si qua fata sinant, iam tum tenditque fovetque.' + #13 + #10 +
-    'Progeniem sed enim Troiano a sanguine duci' + #13 + #10 +
-    'audierat, Tyrias olim quae verteret arces;' + #13 + #10 +
-    'hinc populum late regem belloque superbum' + #13 + #10 +
-    'venturum excidio Libyae:  sic volvere Parcas.' + #13 + #10 +
-    'Id metuens, veterisque memor Saturnia belli,' + #13 + #10 +
-    'prima quod ad Troiam pro caris gesserat Argis---' + #13 + #10 +
-    'necdum etiam causae irarum saevique dolores' + #13 + #10 +
-    'exciderant animo:  manet alta mente repostum' + #13 + #10 +
-    'iudicium Paridis spretaeque iniuria formae,' + #13 + #10 +
-    'et genus invisum, et rapti Ganymedis honores.' + #13 + #10 +
-    'His accensa super, iactatos aequore toto' + #13 + #10 +
-    'Troas, reliquias Danaum atque immitis Achilli,' + #13 + #10 +
-    'arcebat longe Latio, multosque per annos' + #13 + #10 +
-    'errabant, acti fatis, maria omnia circum.' + #13 + #10 +
-    'Tantae molis erat Romanam condere gentem!';
-  RowNumber := RowNumber + 1;
-  FillRecord(RowNumber, Teststring, TestGUID, Testinteger, Testextended,
-    Testdatetime, Testboolean);
-  FTestDataset.Post;
-
-  // Third row: empty/zero numerical values, dates/times, strings
-  FTestDataset.Append;
-  TestBoolean := False;
-  TestDateTime := EncodeDate(1, 1, 1) + EncodeTime(0, 0, 0, 0);
-  TestExtended := 0;
-  TestInteger := Round(TestExtended);
-  TestGuid := '{3F2504E0-4F89-11D3-9A0C-0305E82C3301}';
-  TestString := '';
-  RowNumber := RowNumber + 1;
-  FillRecord(RowNumber, Teststring, TestGUID, Testinteger, Testextended,
-    Testdatetime, Testboolean);
-  FTestDataset.Post;
-
-  // Fourth row: plausible data
-  FTestDataset.Append;
-  TestBoolean := True;
-  TestDateTime := EncodeDate(2005, 9, 10) + EncodeTime(13, 52, 18, 0);
-  TestExtended := 42;
-  TestInteger := Round(TestExtended);
-  TestString := 'The answer to life, the universe, and everything';
-  RowNumber := RowNumber + 1;
-  FillRecord(RowNumber, Teststring, TestGUID, Testinteger, Testextended,
-    Testdatetime, Testboolean);
-  FTestDataset.Post;
-
-  // Make sure recordcount is correct:
-  FTestDataset.Last;
-  FTestDataset.First;
-  AssertEquals('Number of records in test dataset', RowNumber, FTestDataset.RecordCount);
-end;
-
-procedure TTestDBFExport1.Setup;
-const
-  NumberOfDecimals = 2;
-  NumberOfBytes = 10;
-var
-  FieldDef: TFieldDef;
-begin
-  FExportTempDir := GetTempDir(False);
-  FTestDataset := TBufDataset.Create(nil);
-  {Tweaked for dbf export}
-  {We should cover all data types defined in FPC:
-
-  FPC maps "external" types such as ftOracleBlob to
-  internal types, but that can be overridden, which is done
-  by e.g. IBX and mseide.
-  So it makes sense to keep as many datatypes in the exporter code as possible: it documents the mappings and allows other people to use these types without the exporter breaking.
-  }
-  {Sorted by datatype; commented out what doesn't work at the moment in bufdataset
-  See http://docwiki.embarcadero.com/VCL/en/DB.TField.Size for overview of field sizes in the competition product ;)
-  Apparently ftGuid also needs size...
-  }
-
-  {
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftADT';
-  FieldDef.DataType := ftADT;
-  FieldDef.Size := 4096;//large but hopefully not too large for memory.
-  }
-
-  {
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftArray';
-  FieldDef.DataType := ftArray;
-  FieldDef.Size := 10;//the number of elements in the array
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftAutoInc';
-  FieldDef.DataType := ftAutoInc;
-  }
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftBCD';
-  FieldDef.DataType := ftBCD;
-  FieldDef.Size := NumberOfDecimals;
-  //Size is the number of digits after the decimal place
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  //Note dbf 3 has a 10 character field length limit
-  FieldDef.Name := 'ftBlob_4096';
-  FieldDef.DataType := ftBlob;
-  FieldDef.Size := 4096;//large but hopefully not too large for memory.
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftBoolean';
-  FieldDef.DataType := ftBoolean;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftBytes';
-  FieldDef.DataType := ftBytes;
-  FieldDef.Size := NumberOfBytes;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftCurrency';
-  FieldDef.DataType := ftCurrency;
-
-  {
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftCursor';
-  FieldDef.DataType := ftCursor;
-  }
-
-  {
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftDataSet';
-  FieldDef.DataType := ftDataSet;
-  }
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftDate';
-  FieldDef.DataType := ftDate;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftDateTime';
-  FieldDef.DataType := ftDateTime;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftDBaseOle';
-  FieldDef.DataType := ftDBaseOle;
-  FieldDef.Size := 4096;//large but hopefully not too large for memory.
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftFixedChar_2';
-  FieldDef.DataType := ftFixedChar;
-  FieldDef.Size := NumberOfDecimals;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftFixedWideChar_2';
-  FieldDef.DataType := ftFixedWideChar;
-  FieldDef.Size := NumberOfBytes;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftFloat';
-  FieldDef.DataType := ftFloat;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftFMTBcd';
-  FieldDef.DataType := ftFMTBcd;
-  FieldDef.Size := NumberOfDecimals; //the number of digits after the decimal place.
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftFmtMemo';
-  FieldDef.DataType := ftFmtMemo;
-  FieldDef.Size := 4096;//large but hopefully not too large for memory.
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftGraphic';
-  FieldDef.DataType := ftGraphic;
-  FieldDef.Size := 4096;//large but hopefully not too large for memory.
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftGuid';
-  FieldDef.DataType := ftGuid;
-  FieldDef.Size := 38;
-  //Apparently right answer is not 42; had to look up 38 in source code.
-
-  {
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftIDispatch';
-  FieldDef.DataType := ftIDispatch;
-  }
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftInteger';
-  FieldDef.DataType := ftInteger;
-
-  {
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftInterface';
-  FieldDef.DataType := ftInterface;
-  }
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftLargeint';
-  FieldDef.DataType := ftLargeint;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftMemo';
-  FieldDef.DataType := ftMemo;
-  FieldDef.Size := 4096;//large but hopefully not too large for memory.
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftOraBlob';
-  FieldDef.DataType := ftOraBlob;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftOraClob';
-  FieldDef.DataType := ftOraClob;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftParadoxOle';
-  FieldDef.DataType := ftParadoxOle;
-  FieldDef.Size := 4096;//large but hopefully not too large for memory.
-
-  {
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftReference';
-  FieldDef.DataType := ftReference;
-  }
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftSmallInt';
-  FieldDef.DataType := ftInteger;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftString_1';
-  FieldDef.DataType := ftString;
-  FieldDef.Size := 1;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftString_256'; //1 character more than many db string types support
-  FieldDef.DataType := ftString;
-  FieldDef.Size := 256;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftTime';
-  FieldDef.DataType := ftTime;
-
-  {
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftTimeStamp';
-  FieldDef.DataType := ftTimeStamp;
-  }
-
-  {
-  //Bufdataset probably doesn't support this
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  // DBF 10 character limit comes into play here:
-  FieldDef.Name := 'ftTypedBin';
-  FieldDef.DataType := ftTypedBinary;
-  FieldDef.Size := 4096;//large but hopefully not too large for memory.
-  }
-
-  FieldDef.Name := 'ftVariant';
-  FieldDef.DataType := ftVariant;
-  FieldDef.Size := NumberOfBytes;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftVarBytes';
-  FieldDef.DataType := ftVarBytes;
-  FieldDef.Size := NumberOfBytes;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftWideMemo';
-  FieldDef.DataType := ftWideMemo;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftWideString256';
-  FieldDef.DataType := ftWideString;
-  FieldDef.Size := 256;
-
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'ftWord';
-  FieldDef.DataType := ftWord;
-  
-  //Finally, a long field name that should trigger
-  //field renaming code in dbf export
-  //(dbase VII supports up to 32 characters, others up to 10)
-  FieldDef := FTestDataset.FieldDefs.AddFieldDef;
-  FieldDef.Name := 'AVeryLongFieldDataTypeDoesNotMatter';
-  FieldDef.DataType := ftString;
-  FieldDef.Size := 256;
-
-  //Createtable is needed if you use a memds
-  //FTestDataset.CreateTable;
-  //CreateDataset is needed if you use a bufdataset
-  FTestDataset.CreateDataSet;
-
-  // Fill dataset with test data
-  FillTestData;
-end;
-
-procedure TTestDBFExport1.FillRecord(const RowNumber: integer;
-  const TestString: string; const TestGUID: string; const TestInteger: integer;
-  const TestExtended: extended; const TestDatetime: Tdatetime;
-  const TestBoolean: boolean);
-var
-  FieldCounter: integer;
-begin
-  {As our bufdataset doesn't support these datatypes, don't use them:
-ftAutoInc -> exists but doesn't seem to return any data.
-ftCursor
-ftDataSet
-ftInterface
-ftReference
-ftTimeStamp}
-
-  FTestDataset.FieldByName('ftBCD').AsFloat := Testextended;
-  FTestDataset.FieldByName('ftBlob_4096').AsString := Teststring;
-  FTestDataset.FieldByName('ftBoolean').AsBoolean := Testboolean;
-  FTestDataset.FieldByName('ftBytes').AsString := Teststring;
-  FTestDataset.FieldByName('ftCurrency').Ascurrency := Testextended;
-  FTestDataset.FieldByName('ftDate').AsDateTime := Testdatetime;
-  FTestDataset.FieldByName('ftDateTime').AsDateTime := Testdatetime;
-  FTestDataset.FieldByName('ftDBaseOle').AsString := Teststring;
-  FTestDataset.FieldByName('ftFixedChar_2').AsString := Teststring;
-  FTestDataset.FieldByName('ftFixedWideChar_2').AsString := Teststring;
-  FTestDataset.FieldByName('ftFloat').AsFloat := Testextended;
-  FTestDataset.FieldByName('ftFMTBcd').AsFloat := Testextended;
-  FTestDataset.FieldByName('ftFmtMemo').AsString := Teststring;
-  FTestDataset.FieldByName('ftGraphic').AsString := Teststring;
-  FTestDataset.FieldByName('ftGuid').AsString := TestGUID;
-  FTestDataset.FieldByName('ftInteger').AsInteger := Testinteger;
-  FTestDataset.FieldByName('ftLargeint').AsInteger := Testinteger;
-  FTestDataset.FieldByName('ftMemo').AsString := Teststring;
-  FTestDataset.FieldByName('ftOraBlob').AsString := Teststring;
-  {
-  FTestDataset.FieldByName('ftOraClob').AsString := Teststring;
-  }
-  FTestDataset.FieldByName('ftParadoxOle').AsString := Teststring;
-  FTestDataset.FieldByName('ftSmallInt').AsInteger := Testinteger;
-  FTestDataset.FieldByName('ftString_1').AsString := Teststring;
-  FTestDataset.FieldByName('ftString_256').AsString := Teststring;
-  FTestDataset.FieldByName('ftTime').AsDateTime := Testdatetime;
-  {
-  FTestDataset.FieldByName('ftTypedBin').AsString := Teststring;
-  }
-  FTestDataSet.FieldByName('ftVarBytes').AsString := TestString;
-  FTestDataSet.FieldByName('ftVariant').AsString := TestString;
-  FTestDataset.FieldByName('ftWideMemo').AsString := Teststring;
-  FTestDataset.FieldByName('ftWideString256').AsString := Teststring;
-  FTestDataset.FieldByName('ftWord').AsInteger := Abs(Testinteger);
-  FTestDataset.FieldByName('AVeryLongFieldDataTypeDoesNotMatter').AsString := Teststring;
-end;
-
-procedure TTestDBFExport1.Teardown;
-begin
-  FTestDataset.Free;
-end;
-
-initialization
-  Registertest(TTestDBFExport1);
-end.
-

+ 97 - 32
packages/fcl-db/tests/testdbbasics.pas

@@ -141,6 +141,7 @@ type
 
     procedure TestLocate;
     procedure TestLocateCaseIns;
+    procedure TestLocateCaseInsInts;
 
     procedure TestFirst;
     procedure TestIntFilter;
@@ -429,7 +430,10 @@ begin
       open;
       DataEvents := '';
       Resync([rmExact]);
-      CheckEquals('deDataSetChange:0;DataSetChanged;',DataEvents);
+      if IsUniDirectional then
+        CheckEquals('',DataEvents)
+      else
+        CheckEquals('deDataSetChange:0;DataSetChanged;',DataEvents);
       DataEvents := '';
       next;
       CheckEquals('deCheckBrowseMode:0;DataEvent;deDataSetScroll:0;DataSetScrolled:1;DataSetChanged;',DataEvents);
@@ -715,17 +719,28 @@ begin
 
     lds.Open;
     Open;
-    CheckTrue(FieldByName('ID').CanModify);
+    if IsUniDirectional then
+      // The CanModify property is always False for UniDirectional datasets
+      CheckFalse(FieldByName('ID').CanModify)
+    else
+      CheckTrue(FieldByName('ID').CanModify);
     CheckFalse(FieldByName('LookupFld').CanModify);
     CheckFalse(FieldByName('ID').ReadOnly);
     CheckFalse(FieldByName('LookupFld').ReadOnly);
 
     CheckEquals(1,FieldByName('ID').AsInteger);
-    CheckEquals('TestName1',FieldByName('LookupFld').AsString);
+    if IsUniDirectional then
+      // Lookup fields are not supported by UniDirectional datasets
+      CheckTrue(FieldByName('LookupFld').IsNull)
+    else
+      CheckEquals('TestName1',FieldByName('LookupFld').AsString);
     Next;
     Next;
     CheckEquals(3,FieldByName('ID').AsInteger);
-    CheckEquals('TestName3',FieldByName('LookupFld').AsString);
+    if IsUniDirectional then
+      CheckTrue(FieldByName('LookupFld').IsNull)
+    else
+      CheckEquals('TestName3',FieldByName('LookupFld').AsString);
 
     Close;
     lds.Close;
@@ -910,6 +925,8 @@ begin
 end;
 
 procedure TTestCursorDBBasics.TestLocateCaseIns;
+// Tests case insensitive locate, also partial key locate, both against string fields.
+// Together with TestLocateCaseInsInts, checks 23509 DBF: locate with loPartialkey behaviour differs depending on index use
 begin
   with DBConnector.GetNDataset(true,13) do
     begin
@@ -927,38 +944,79 @@ begin
     end;
 end;
 
-procedure TTestDBBasics.TestSetFieldValues;
-var PassException : boolean;
+procedure TTestCursorDBBasics.TestLocateCaseInsInts;
+// Tests case insensitive locate, also partial key locate, both against integer fields.
+// Together with TestLocateCaseIns, checks 23509 DBF: locate with loPartialkey behaviour differs depending on index use
 begin
-  with DBConnector.GetNDataset(true,11) do
+  with DBConnector.GetNDataset(true,13) do
     begin
     open;
+    // To really test bug 23509: we should first have a record that matches greater than for non-string locate:
     first;
-    edit;
-    FieldValues['id']:=5;
+    insert;
+    fieldbyname('id').AsInteger:=55;
+    fieldbyname('name').AsString:='TestName55';
     post;
-    CheckEquals('TestName1',FieldByName('name').AsString);
+    first;
+
+    CheckTrue(Locate('id',vararrayof([5]),[]));
     CheckEquals(5,FieldByName('id').AsInteger);
-    edit;
-    FieldValues['name']:='FieldValuesTestName';
-    post;
-    CheckEquals('FieldValuesTestName',FieldByName('name').AsString);
+    first;
+
+    CheckTrue(Locate('id',vararrayof([5]),[loCaseInsensitive]));
     CheckEquals(5,FieldByName('id').AsInteger);
-    edit;
-    FieldValues['id;name']:= VarArrayOf([243,'ValuesTestName']);
-    post;
-    CheckEquals('ValuesTestName',FieldByName('name').AsString);
-    CheckEquals(243,FieldByName('id').AsInteger);
-    
-    PassException:=false;
-    try
-      edit;
-      FieldValues['id;name;fake']:= VarArrayOf([243,'ValuesTestName',4]);
-    except
-      on E: EDatabaseError do PassException := True;
+    first;
+
+    // Check specifying partial key doesn't influence search results
+    CheckTrue(Locate('id',vararrayof([5]),[loPartialKey]));
+    CheckEquals(5,FieldByName('id').AsInteger);
+    first;
+
+    CheckTrue(Locate('id',vararrayof([5]),[loPartialKey, loCaseInsensitive]));
+    CheckEquals(5,FieldByName('id').AsInteger);
+
+    close;
     end;
-    post;
-    CheckTrue(PassException);
+end;
+
+procedure TTestDBBasics.TestSetFieldValues;
+var PassException : boolean;
+begin
+  with DBConnector.GetNDataset(true,11) do
+    begin
+    open;
+    // First and Next methods are supported by UniDirectional datasets
+    first;
+    if IsUniDirectional then
+      CheckException(Edit, EDatabaseError)
+    else
+      begin
+      edit;
+      FieldValues['id']:=5;
+      post;
+      CheckEquals('TestName1',FieldByName('name').AsString);
+      CheckEquals(5,FieldByName('id').AsInteger);
+      edit;
+      FieldValues['name']:='FieldValuesTestName';
+      post;
+      CheckEquals('FieldValuesTestName',FieldByName('name').AsString);
+      CheckEquals(5,FieldByName('id').AsInteger);
+      edit;
+      FieldValues['id;name']:= VarArrayOf([243,'ValuesTestName']);
+      post;
+      CheckEquals('ValuesTestName',FieldByName('name').AsString);
+      CheckEquals(243,FieldByName('id').AsInteger);
+    
+      PassException:=false;
+      try
+        edit;
+        FieldValues['id;name;fake']:= VarArrayOf([243,'ValuesTestName',4]);
+      except
+        on E: EDatabaseError do PassException := True;
+      end;
+      post;
+      CheckTrue(PassException);
+      end;
     end;
 end;
 
@@ -2150,6 +2208,7 @@ begin
   else
     dataset.fieldbyname('CALCFLD').AsInteger := 1;
   end;
+  CheckTrue(DataSet.State=dsCalcFields, 'State');
 end;
 
 procedure TTestDBBasics.TestCalculatedField;
@@ -2183,10 +2242,16 @@ begin
     CheckEquals(true,FieldByName('CALCFLD').isnull);
     next;
     CheckEquals(1234,FieldByName('CALCFLD').AsInteger);
-    edit;
-    FieldByName('ID').AsInteger := 10;
-    post;
-    CheckEquals(true,FieldByName('CALCFLD').isnull);
+    if IsUniDirectional then
+      // The CanModify property is always False, so attempts to put the dataset into edit mode always fail
+      CheckException(Edit, EDatabaseError)
+    else
+      begin
+      Edit;
+      FieldByName('ID').AsInteger := 10;
+      Post;
+      CheckEquals(true,FieldByName('CALCFLD').isnull);
+      end;
     close;
     AFld1.Free;
     AFld2.Free;

+ 157 - 151
packages/fcl-db/tests/testfieldtypes.pas

@@ -57,7 +57,6 @@ type
     procedure TestNonNullableParams;
     procedure TestDblQuoteEscComments;
     procedure TestpfInUpdateFlag; // bug 7565
-    procedure TestInt;
     procedure TestScript;
     procedure TestInsertReturningQuery;
     procedure TestOpenStoredProc;
@@ -76,12 +75,13 @@ type
     procedure TestBlobSize;
 
     procedure TestLargeRecordSize;
+    procedure TestInt;
     procedure TestNumeric;
     procedure TestFloat;
+    procedure TestDate;
     procedure TestDateTime;       // bug 6925
     procedure TestString;
     procedure TestUnlVarChar;
-    procedure TestDate;
 
     procedure TestNullValues;
     procedure TestParamQuery;
@@ -231,30 +231,6 @@ begin
   end;
 end;
 
-procedure TTestFieldTypes.TestInt;
-
-var
-  i          : byte;
-
-begin
-  CreateTableWithFieldType(ftInteger,'INT');
-  TestFieldDeclaration(ftInteger,4);
-
-  for i := 0 to testIntValuesCount-1 do
-    TSQLDBConnector(DBConnector).Connection.ExecuteDirect('insert into FPDEV2 (FT) values (' + inttostr(testIntValues[i]) + ')');
-
-  with TSQLDBConnector(DBConnector).Query do
-    begin
-    Open;
-    for i := 0 to testIntValuesCount-1 do
-      begin
-      AssertEquals(testIntValues[i],fields[0].AsInteger);
-      Next;
-      end;
-    close;
-    end;
-end;
-
 procedure TTestFieldTypes.TestLargeRecordSize;
 
 begin
@@ -278,6 +254,56 @@ begin
     end;
 end;
 
+procedure TTestFieldTypes.CreateTableWithFieldType(ADatatype: TFieldType;
+  ASQLTypeDecl: string);
+begin
+  with TSQLDBConnector(DBConnector) do
+  begin
+    Connection.ExecuteDirect('create table FPDEV2 (FT ' +ASQLTypeDecl+ ')');
+    // Firebird/Interbase need a commit after a DDL statement. Not necessary for the other connections
+    CommitDDL;
+  end;
+end;
+
+procedure TTestFieldTypes.TestFieldDeclaration(ADatatype: TFieldType;
+  ADataSize: integer);
+begin
+  with TSQLDBConnector(DBConnector).Query do
+    begin
+    SQL.Clear;
+    SQL.Add('select * from FPDEV2');
+    Open;
+    AssertEquals(1,FieldCount);
+    AssertTrue(CompareText('FT',fields[0].FieldName)=0);
+    AssertEquals('DataSize', ADataSize, Fields[0].DataSize);
+    AssertEquals('DataType', ord(ADatatype), ord(Fields[0].DataType));
+    Close;
+    end;
+end;
+
+procedure TTestFieldTypes.TestInt;
+
+var
+  i          : byte;
+
+begin
+  CreateTableWithFieldType(ftInteger,'INT');
+  TestFieldDeclaration(ftInteger,4);
+
+  for i := 0 to testIntValuesCount-1 do
+    TSQLDBConnector(DBConnector).Connection.ExecuteDirect('insert into FPDEV2 (FT) values (' + inttostr(testIntValues[i]) + ')');
+
+  with TSQLDBConnector(DBConnector).Query do
+    begin
+    Open;
+    for i := 0 to testIntValuesCount-1 do
+      begin
+      AssertEquals(testIntValues[i],fields[0].AsInteger);
+      Next;
+      end;
+    close;
+    end;
+end;
 
 procedure TTestFieldTypes.TestNumeric;
 
@@ -356,6 +382,32 @@ begin
   end;
 end;
 
+procedure TTestFieldTypes.TestFloat;
+const
+  testValuesCount = 21;
+  testValues : Array[0..testValuesCount-1] of double = (-maxSmallint-1,-maxSmallint,-256,-255,-128,-127,-1,0,1,127,128,255,256,maxSmallint,maxSmallint+1,0.123456,-0.123456,4.35,12.434E7,9.876e-5,123.45678);
+
+var
+  i          : byte;
+
+begin
+  CreateTableWithFieldType(ftFloat,'FLOAT');
+  TestFieldDeclaration(ftFloat,sizeof(double));
+
+  for i := 0 to testValuesCount-1 do
+    TSQLDBConnector(DBConnector).Connection.ExecuteDirect('insert into FPDEV2 (FT) values (' + floattostr(testValues[i],DBConnector.FormatSettings) + ')');
+
+  with TSQLDBConnector(DBConnector).Query do
+    begin
+    Open;
+    for i := 0 to testValuesCount-1 do
+      begin
+      AssertEquals(testValues[i],fields[0].AsFloat);
+      Next;
+      end;
+    close;
+    end;
+end;
 
 procedure TTestFieldTypes.TestString;
 
@@ -486,6 +538,73 @@ begin
 
 end;
 
+procedure TTestFieldTypes.TestDateTime;
+
+const
+  testValuesCount = 31;
+  testValues : Array[0..testValuesCount-1] of string = (
+    '2000-01-01',
+    '1999-12-31',
+    '2004-02-29',
+    '2004-03-01',
+    '1991-02-28',
+    '1991-03-01',
+    '1977-09-29',
+    '2000-01-01 10:00:00',
+    '2000-01-01 23:59:59',
+    '1994-03-06 11:54:30',
+    '2040-10-16',                   // MySQL 4.0 doesn't support datetimes before 1970 or after 2038
+    '2100-01-01 01:01:01',
+    '1903-04-02 01:04:02',
+    '1900-01-01',
+    '1899-12-31',
+    '1899-12-30',
+    '1899-12-29',
+    '1899-12-30 18:00:51',
+    '1899-12-30 04:00:51',
+    '1899-12-29 04:00:51',
+    '1899-12-29 18:00:51',
+    '1815-09-24 03:47:22',
+    '1800-03-30',
+    '1754-06-04',
+    '1650-05-10',                   // MS SQL 2005 doesn't support datetimes before 1753
+    '1400-02-03 12:21:53',
+    '1333-02-03 21:44:21',
+    '0904-04-12',
+    '0354-11-20 21:25:15',
+    '0199-07-09',
+    '0001-01-01'
+  );
+
+var
+  i : byte;
+
+begin
+  CreateTableWithFieldType(ftDateTime,FieldtypeDefinitions[ftDateTime]);
+  TestFieldDeclaration(ftDateTime,8);
+
+  for i := 0 to testValuesCount-1 do
+    if SQLConnType=oracle then
+      TSQLDBConnector(DBConnector).Connection.ExecuteDirect('insert into FPDEV2 (FT) values (to_date (''' + testValues[i] + ''',''YYYY-MM-DD HH24:MI:SS''))')
+    else
+      TSQLDBConnector(DBConnector).Connection.ExecuteDirect('insert into FPDEV2 (FT) values (''' + testValues[i] + ''')');
+
+  with TSQLDBConnector(DBConnector).Query do
+    begin
+    Open;
+    for i := 0 to testValuesCount-1 do
+      begin
+      if length(testValues[i]) < 12 then
+        AssertEquals(testValues[i],FormatDateTime('yyyy/mm/dd', fields[0].AsDateTime, DBConnector.FormatSettings))
+      else
+        AssertEquals(testValues[i],FormatDateTime('yyyy/mm/dd hh:mm:ss', fields[0].AsDateTime, DBConnector.FormatSettings));
+      Next;
+      end;
+    close;
+    end;
+end;
+
+
 procedure TTestFieldTypes.TestChangeBlob;
 
 var s : string;
@@ -584,100 +703,6 @@ begin
     end;
 end;
 
-
-procedure TTestFieldTypes.TestDateTime;
-
-const
-  testValuesCount = 31;
-  testValues : Array[0..testValuesCount-1] of string = (
-    '2000-01-01',
-    '1999-12-31',
-    '2004-02-29',
-    '2004-03-01',
-    '1991-02-28',
-    '1991-03-01',
-    '1977-09-29',
-    '2000-01-01 10:00:00',
-    '2000-01-01 23:59:59',
-    '1994-03-06 11:54:30',
-    '2040-10-16',                   // MySQL 4.0 doesn't support datetimes before 1970 or after 2038
-    '2100-01-01 01:01:01',
-    '1903-04-02 01:04:02',
-    '1900-01-01',
-    '1899-12-31',
-    '1899-12-30',
-    '1899-12-29',
-    '1899-12-30 18:00:51',
-    '1899-12-30 04:00:51',
-    '1899-12-29 04:00:51',
-    '1899-12-29 18:00:51',
-    '1815-09-24 03:47:22',
-    '1800-03-30',
-    '1754-06-04',
-    '1650-05-10',                   // MS SQL 2005 doesn't support datetimes before 1753
-    '1400-02-03 12:21:53',
-    '1333-02-03 21:44:21',
-    '0904-04-12',
-    '0354-11-20 21:25:15',
-    '0199-07-09',
-    '0001-01-01'
-  );
-
-var
-  i : byte;
-
-begin
-  CreateTableWithFieldType(ftDateTime,FieldtypeDefinitions[ftDateTime]);
-  TestFieldDeclaration(ftDateTime,8);
-
-  for i := 0 to testValuesCount-1 do
-    if SQLConnType=oracle then
-      TSQLDBConnector(DBConnector).Connection.ExecuteDirect('insert into FPDEV2 (FT) values (to_date (''' + testValues[i] + ''',''YYYY-MM-DD HH24:MI:SS''))')
-    else
-      TSQLDBConnector(DBConnector).Connection.ExecuteDirect('insert into FPDEV2 (FT) values (''' + testValues[i] + ''')');
-
-  with TSQLDBConnector(DBConnector).Query do
-    begin
-    Open;
-    for i := 0 to testValuesCount-1 do
-      begin
-      if length(testValues[i]) < 12 then
-        AssertEquals(testValues[i],FormatDateTime('yyyy/mm/dd', fields[0].AsDateTime, DBConnector.FormatSettings))
-      else
-        AssertEquals(testValues[i],FormatDateTime('yyyy/mm/dd hh:mm:ss', fields[0].AsDateTime, DBConnector.FormatSettings));
-      Next;
-      end;
-    close;
-    end;
-end;
-
-procedure TTestFieldTypes.TestFloat;
-const
-  testValuesCount = 21;
-  testValues : Array[0..testValuesCount-1] of double = (-maxSmallint-1,-maxSmallint,-256,-255,-128,-127,-1,0,1,127,128,255,256,maxSmallint,maxSmallint+1,0.123456,-0.123456,4.35,12.434E7,9.876e-5,123.45678);
-
-var
-  i          : byte;
-
-begin
-  CreateTableWithFieldType(ftFloat,'FLOAT');
-  TestFieldDeclaration(ftFloat,sizeof(double));
-
-  for i := 0 to testValuesCount-1 do
-    TSQLDBConnector(DBConnector).Connection.ExecuteDirect('insert into FPDEV2 (FT) values (' + floattostr(testValues[i],DBConnector.FormatSettings) + ')');
-
-  with TSQLDBConnector(DBConnector).Query do
-    begin
-    Open;
-    for i := 0 to testValuesCount-1 do
-      begin
-      AssertEquals(testValues[i],fields[0].AsFloat);
-      Next;
-      end;
-    close;
-    end;
-end;
-
 procedure TTestFieldTypes.TestNullValues;
 begin
   TSQLDBConnector(DBConnector).Connection.ExecuteDirect('create table FPDEV2 (FIELD1 INT, FIELD2 INT)');
@@ -1028,33 +1053,6 @@ begin
 
 end;
 
-procedure TTestFieldTypes.CreateTableWithFieldType(ADatatype: TFieldType;
-  ASQLTypeDecl: string);
-begin
-  with TSQLDBConnector(DBConnector) do
-  begin
-    Connection.ExecuteDirect('create table FPDEV2 (FT ' +ASQLTypeDecl+ ')');
-    // Firebird/Interbase need a commit after a DDL statement. Not necessary for the other connections
-    CommitDDL;
-  end;
-end;
-
-procedure TTestFieldTypes.TestFieldDeclaration(ADatatype: TFieldType;
-  ADataSize: integer);
-begin
-  with TSQLDBConnector(DBConnector).Query do
-    begin
-    SQL.Clear;
-    SQL.Add('select * from FPDEV2');
-    Open;
-    AssertEquals(1,FieldCount);
-    AssertTrue(CompareText('FT',fields[0].FieldName)=0);
-    AssertEquals('DataSize', ADataSize, Fields[0].DataSize);
-    AssertEquals('DataType', ord(ADatatype), ord(Fields[0].DataType));
-    Close;
-    end;
-end;
-
 procedure TTestFieldTypes.TestQueryAfterReconnect;
 var DS: TDataset;
 begin
@@ -1186,7 +1184,7 @@ begin
 end;
 
 procedure TTestFieldTypes.TestStringLargerThen8192;
-
+// See also: TestInsertLargeStrFields
 var
   s             : string;
   i             : integer;
@@ -1515,9 +1513,13 @@ begin
 end;
 
 procedure TTestFieldTypes.TestInsertLargeStrFields;
+// See also: TestStringLargerThen8192
 const
-  FieldValue='test1';
+  FieldValue1='test1';
+var
+  FieldValue2: string;
 begin
+  FieldValue2:=StringOfChar('t', 16000);
   with TSQLDBConnector(DBConnector) do
     begin
     Connection.ExecuteDirect('create table FPDEV2 (  ' +
@@ -1530,11 +1532,15 @@ begin
 
     query.sql.Text:='select * from FPDEV2';
     Query.Open;
-    Query.InsertRecord([1,FieldValue]);
+    Query.InsertRecord([1,FieldValue1]); // string length <= 8192 (dsMaxStringSize)
+    Query.InsertRecord([2,FieldValue2]); // string length >  8192 (dsMaxStringSize)
     Query.ApplyUpdates;
     Query.Close;
     Query.Open;
-    AssertEquals(FieldValue, Query.FieldByName('NAME').AsString);
+    AssertEquals(FieldValue1, Query.FieldByName('NAME').AsString);
+    Query.Next;
+    AssertEquals(length(FieldValue2), length(Query.FieldByName('NAME').AsString));
+    AssertEquals(FieldValue2, Query.FieldByName('NAME').AsString);
     Query.Close;
     end;
 end;

+ 1 - 2
packages/fcl-db/tests/toolsunit.pas

@@ -397,8 +397,6 @@ end;
 
 { TTestDataLink }
 
-{$IFDEF FPC}
-
 procedure TTestDataLink.DataSetScrolled(Distance: Integer);
 begin
   DataEvents := DataEvents + 'DataSetScrolled' + ':' + inttostr(Distance) + ';';
@@ -411,6 +409,7 @@ begin
   inherited DataSetChanged;
 end;
 
+{$IFDEF FPC}
 procedure TTestDataLink.DataEvent(Event: TDataEvent; Info: Ptrint);
 {$ELSE}
 procedure TTestDataLink.DataEvent(Event: TDataEvent; Info: Longint);