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/README.txt svneol=native#text/plain
 packages/fcl-db/tests/bufdatasettoolsunit.pas 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/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/dbftoolsunit.pas svneol=native#text/plain
 packages/fcl-db/tests/dbtestframework.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.lpi svneol=native#text/plain

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

@@ -1233,11 +1233,9 @@ end;
 procedure TCustomBufDataset.InternalFirst;
 procedure TCustomBufDataset.InternalFirst;
 begin
 begin
   with FCurrentIndex do
   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;
     SetToFirstRecord;
-    end;
 end;
 end;
 
 
 procedure TCustomBufDataset.InternalLast;
 procedure TCustomBufDataset.InternalLast;
@@ -3609,7 +3607,8 @@ end;
 
 
 procedure TUniDirectionalBufIndex.SetToFirstRecord;
 procedure TUniDirectionalBufIndex.SetToFirstRecord;
 begin
 begin
-  DatabaseError(SUniDirectional);
+  // for UniDirectional datasets should be [Internal]First valid method call
+  // do nothing
 end;
 end;
 
 
 procedure TUniDirectionalBufIndex.SetToLastRecord;
 procedure TUniDirectionalBufIndex.SetToLastRecord;

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

@@ -139,15 +139,16 @@ var
   OldState: TDatasetState;
   OldState: TDatasetState;
 begin
 begin
   FCalcBuffer := Buffer; 
   FCalcBuffer := Buffer; 
-  if not IsUniDirectional and (FState <> dsInternalCalc) then
+  if FState <> dsInternalCalc then
   begin
   begin
     OldState := FState;
     OldState := FState;
     FState := dsCalcFields;
     FState := dsCalcFields;
     try
     try
       ClearCalcFields(FCalcBuffer);
       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
     finally
       DoOnCalcFields;
       DoOnCalcFields;
       FState := OldState;
       FState := OldState;

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

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

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

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

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

@@ -1758,7 +1758,7 @@ var
   var
   var
     sCompare: String;
     sCompare: String;
   begin
   begin
-    if (Field.DataType = ftString) then
+    if (Field.DataType in [ftString,ftWideString]) then
     begin
     begin
       sCompare := VarToStr(varCompare);
       sCompare := VarToStr(varCompare);
       if loCaseInsensitive in Options then
       if loCaseInsensitive in Options then
@@ -1785,6 +1785,8 @@ var
       end;
       end;
     end
     end
     else
     else
+      // Not a string; could be date, integer etc.
+      // Follow e.g. FPC bufdataset by searching for equal  
       Result := Field.Value = varCompare;
       Result := Field.Value = varCompare;
   end;
   end;
 
 
@@ -1848,7 +1850,9 @@ var
   lTempBuffer: array [0..100] of Char;
   lTempBuffer: array [0..100] of Char;
   acceptable, checkmatch: boolean;
   acceptable, checkmatch: boolean;
 begin
 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
     searchFlag := stGreaterEqual
   else
   else
     searchFlag := stEqual;
     searchFlag := stEqual;

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

@@ -18,7 +18,6 @@ type
   TPQTrans = Class(TSQLHandle)
   TPQTrans = Class(TSQLHandle)
     protected
     protected
     PGConn        : PPGConn;
     PGConn        : PPGConn;
-    ErrorOccured  : boolean;
   end;
   end;
 
 
   TPQCursor = Class(TSQLCursor)
   TPQCursor = Class(TSQLCursor)
@@ -41,16 +40,22 @@ type
       STATEMENT_POSITION:string;
       STATEMENT_POSITION:string;
   end;
   end;
 
 
+  TTranConnection= class
+  protected
+    FPGConn        : PPGConn;
+    FTranActive    : boolean
+  end;
+
   { TPQConnection }
   { TPQConnection }
 
 
   TPQConnection = class (TSQLConnection)
   TPQConnection = class (TSQLConnection)
   private
   private
+    FConnectionPool      : array of TTranConnection;
     FCursorCount         : word;
     FCursorCount         : word;
     FConnectString       : string;
     FConnectString       : string;
     FSQLDatabaseHandle   : pointer;
     FSQLDatabaseHandle   : pointer;
     FIntegerDateTimes    : boolean;
     FIntegerDateTimes    : boolean;
     procedure CheckResultError(var res: PPGresult; conn:PPGconn; ErrMsg: string);
     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;
     function TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer) : TFieldType;
     procedure ExecuteDirectPG(const Query : String);
     procedure ExecuteDirectPG(const Query : String);
   protected
   protected
@@ -215,6 +220,7 @@ function TPQConnection.RollBack(trans : TSQLHandle) : boolean;
 var
 var
   res : PPGresult;
   res : PPGresult;
   tr  : TPQTrans;
   tr  : TPQTrans;
+  i   : Integer;
 begin
 begin
   result := false;
   result := false;
 
 
@@ -225,7 +231,13 @@ begin
   CheckResultError(res,tr.PGConn,SErrRollbackFailed);
   CheckResultError(res,tr.PGConn,SErrRollbackFailed);
 
 
   PQclear(res);
   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;
   result := true;
 end;
 end;
 
 
@@ -233,6 +245,7 @@ function TPQConnection.Commit(trans : TSQLHandle) : boolean;
 var
 var
   res : PPGresult;
   res : PPGresult;
   tr  : TPQTrans;
   tr  : TPQTrans;
+  i   : Integer;
 begin
 begin
   result := false;
   result := false;
 
 
@@ -242,7 +255,13 @@ begin
   CheckResultError(res,tr.PGConn,SErrCommitFailed);
   CheckResultError(res,tr.PGConn,SErrCommitFailed);
 
 
   PQclear(res);
   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;
   result := true;
 end;
 end;
 
 
@@ -250,30 +269,48 @@ function TPQConnection.StartdbTransaction(trans : TSQLHandle; AParams : string)
 var
 var
   res : PPGresult;
   res : PPGresult;
   tr  : TPQTrans;
   tr  : TPQTrans;
+  i   : Integer;
 begin
 begin
+  result:=false;
   tr := trans as TPQTrans;
   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
     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
     end
-  else
+  else //re-use existing connection
     begin
     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;
     end;
+  res := PQexec(tr.PGConn, 'BEGIN');
+  CheckResultError(res,tr.PGConn,sErrTransactionFailed);
+
+  PQclear(res);
+  result := true;
 end;
 end;
 
 
 procedure TPQConnection.RollBackRetaining(trans : TSQLHandle);
 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
 // 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
   if PQparameterStatus<>nil then
     FIntegerDateTimes := PQparameterStatus(FSQLDatabaseHandle,'integer_datetimes') = 'on';
     FIntegerDateTimes := PQparameterStatus(FSQLDatabaseHandle,'integer_datetimes') = 'on';
+  SetLength(FConnectionPool,1);
+  FConnectionPool[0]:=TTranConnection.Create;
+  FConnectionPool[0].FPGConn:=FSQLDatabaseHandle;
+  FConnectionPool[0].FTranActive:=false;
 end;
 end;
 
 
 procedure TPQConnection.DoInternalDisconnect;
 procedure TPQConnection.DoInternalDisconnect;
+var i:integer;
 begin
 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}
 {$IfDef LinkDynamically}
   ReleasePostgres3;
   ReleasePostgres3;
 {$EndIf}
 {$EndIf}
-
 end;
 end;
 
 
 procedure TPQConnection.CheckResultError(var res: PPGresult; conn: PPGconn;
 procedure TPQConnection.CheckResultError(var res: PPGresult; conn: PPGconn;
   ErrMsg: string);
   ErrMsg: string);
 var
 var
   E: EPQDatabaseError;
   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
 begin
   if (PQresultStatus(res) <> PGRES_COMMAND_OK) then
   if (PQresultStatus(res) <> PGRES_COMMAND_OK) then
     begin
     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);
     PQclear(res);
     res:=nil;
     res:=nil;
     if assigned(conn) then
     if assigned(conn) then
+      begin
       PQFinish(conn);
       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;
     raise E;
     end;
     end;
 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;
 function TPQConnection.TranslateFldType(res : PPGresult; Tuple : integer; out Size : integer) : TFieldType;
 const VARHDRSZ=sizeof(longint);
 const VARHDRSZ=sizeof(longint);
 var li : longint;
 var li : longint;
@@ -421,7 +470,7 @@ begin
                                else
                                else
                                  size := (li-VARHDRSZ) and $FFFF;
                                  size := (li-VARHDRSZ) and $FFFF;
                                end;
                                end;
-                             if size > dsMaxStringSize then size := dsMaxStringSize;
+                             if size > MaxSmallint then size := MaxSmallint;
                              end;
                              end;
 //    Oid_text               : Result := ftstring;
 //    Oid_text               : Result := ftstring;
     Oid_text               : Result := ftMemo;
     Oid_text               : Result := ftMemo;
@@ -599,7 +648,7 @@ begin
     res:=nil;
     res:=nil;
     if FPrepared then
     if FPrepared then
       begin
       begin
-      if not tr.ErrorOccured then
+      if PQtransactionStatus(tr.PGConn) <> PQTRANS_INERROR then
         begin
         begin
         res := PQexec(tr.PGConn,pchar('deallocate '+StmtName));
         res := PQexec(tr.PGConn,pchar('deallocate '+StmtName));
         CheckResultError(res,nil,SErrUnPrepareFailed);
         CheckResultError(res,nil,SErrUnPrepareFailed);
@@ -699,10 +748,9 @@ begin
 
 
     if assigned(res) and not (PQresultStatus(res) in [PGRES_COMMAND_OK,PGRES_TUPLES_OK]) then
     if assigned(res) and not (PQresultStatus(res) in [PGRES_COMMAND_OK,PGRES_TUPLES_OK]) then
       begin
       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);
       CheckResultError(res,nil,SErrExecuteFailed);
       end;
       end;
 
 
@@ -734,8 +782,36 @@ begin
 end;
 end;
 
 
 function TPQConnection.GetHandle: pointer;
 function TPQConnection.GetHandle: pointer;
+var
+  i:integer;
 begin
 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;
 end;
 
 
 function TPQConnection.Fetch(cursor : TSQLCursor) : boolean;
 function TPQConnection.Fetch(cursor : TSQLCursor) : boolean;
@@ -850,7 +926,7 @@ begin
             else
             else
             begin
             begin
               li := pqgetlength(res,curtuple,x);
               li := pqgetlength(res,curtuple,x);
-              if li > dsMaxStringSize then li := dsMaxStringSize;
+              if li > FieldDef.Size then li := FieldDef.Size;
               Move(CurrBuff^, Buffer^, li);
               Move(CurrBuff^, Buffer^, li);
             end;
             end;
           end;
           end;
@@ -1001,50 +1077,51 @@ function TPQConnection.GetSchemaInfoSQL(SchemaType: TSchemaType;
 var s : string;
 var s : string;
 
 
 begin
 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
   case SchemaType of
     stTables     : s := 'select '+
     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';
                         'order by relname';
 
 
     stSysTables  : s := 'select '+
     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';
                         'order by relname';
     stColumns    : s := 'select '+
     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';
                         'order by a.attname';
   else
   else
     DatabaseError(SMetadataUnavailable)
     DatabaseError(SMetadataUnavailable)
@@ -1089,7 +1166,7 @@ begin
       citServerVersion,
       citServerVersion,
       citServerVersionString:
       citServerVersionString:
         if Connected then
         if Connected then
-          Result:=format('%6.6d', [PQserverVersion(FSQLDatabaseHandle)]);
+          Result:=format('%6.6d', [PQserverVersion(GetHandle)]);
       citClientName:
       citClientName:
         Result:=TPQConnectionDef.LoadedLibraryName;
         Result:=TPQConnectionDef.LoadedLibraryName;
     else
     else

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

@@ -278,6 +278,7 @@ type
     procedure SetReadOnly(AValue : Boolean); override;
     procedure SetReadOnly(AValue : Boolean); override;
     Function LogEvent(EventType : TDBEventType) : Boolean;
     Function LogEvent(EventType : TDBEventType) : Boolean;
     Procedure Log(EventType : TDBEventType; Const Msg : String); virtual;
     Procedure Log(EventType : TDBEventType; Const Msg : String); virtual;
+    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
   public
   public
     procedure Prepare; virtual;
     procedure Prepare; virtual;
     procedure UnPrepare; virtual;
     procedure UnPrepare; virtual;
@@ -286,7 +287,6 @@ type
     destructor Destroy; override;
     destructor Destroy; override;
     procedure SetSchemaInfo( ASchemaType : TSchemaType; ASchemaObjectName, ASchemaPattern : string); virtual;
     procedure SetSchemaInfo( ASchemaType : TSchemaType; ASchemaObjectName, ASchemaPattern : string); virtual;
     property Prepared : boolean read IsPrepared;
     property Prepared : boolean read IsPrepared;
-    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
     function RowsAffected: TRowsCount; virtual;
     function RowsAffected: TRowsCount; virtual;
     function ParamByName(Const AParamName : String) : TParam;
     function ParamByName(Const AParamName : String) : TParam;
   protected
   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 TestLocate;
     procedure TestLocateCaseIns;
     procedure TestLocateCaseIns;
+    procedure TestLocateCaseInsInts;
 
 
     procedure TestFirst;
     procedure TestFirst;
     procedure TestIntFilter;
     procedure TestIntFilter;
@@ -429,7 +430,10 @@ begin
       open;
       open;
       DataEvents := '';
       DataEvents := '';
       Resync([rmExact]);
       Resync([rmExact]);
-      CheckEquals('deDataSetChange:0;DataSetChanged;',DataEvents);
+      if IsUniDirectional then
+        CheckEquals('',DataEvents)
+      else
+        CheckEquals('deDataSetChange:0;DataSetChanged;',DataEvents);
       DataEvents := '';
       DataEvents := '';
       next;
       next;
       CheckEquals('deCheckBrowseMode:0;DataEvent;deDataSetScroll:0;DataSetScrolled:1;DataSetChanged;',DataEvents);
       CheckEquals('deCheckBrowseMode:0;DataEvent;deDataSetScroll:0;DataSetScrolled:1;DataSetChanged;',DataEvents);
@@ -715,17 +719,28 @@ begin
 
 
     lds.Open;
     lds.Open;
     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('LookupFld').CanModify);
     CheckFalse(FieldByName('ID').ReadOnly);
     CheckFalse(FieldByName('ID').ReadOnly);
     CheckFalse(FieldByName('LookupFld').ReadOnly);
     CheckFalse(FieldByName('LookupFld').ReadOnly);
 
 
     CheckEquals(1,FieldByName('ID').AsInteger);
     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;
     Next;
     Next;
     CheckEquals(3,FieldByName('ID').AsInteger);
     CheckEquals(3,FieldByName('ID').AsInteger);
-    CheckEquals('TestName3',FieldByName('LookupFld').AsString);
+    if IsUniDirectional then
+      CheckTrue(FieldByName('LookupFld').IsNull)
+    else
+      CheckEquals('TestName3',FieldByName('LookupFld').AsString);
 
 
     Close;
     Close;
     lds.Close;
     lds.Close;
@@ -910,6 +925,8 @@ begin
 end;
 end;
 
 
 procedure TTestCursorDBBasics.TestLocateCaseIns;
 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
 begin
   with DBConnector.GetNDataset(true,13) do
   with DBConnector.GetNDataset(true,13) do
     begin
     begin
@@ -927,38 +944,79 @@ begin
     end;
     end;
 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
 begin
-  with DBConnector.GetNDataset(true,11) do
+  with DBConnector.GetNDataset(true,13) do
     begin
     begin
     open;
     open;
+    // To really test bug 23509: we should first have a record that matches greater than for non-string locate:
     first;
     first;
-    edit;
-    FieldValues['id']:=5;
+    insert;
+    fieldbyname('id').AsInteger:=55;
+    fieldbyname('name').AsString:='TestName55';
     post;
     post;
-    CheckEquals('TestName1',FieldByName('name').AsString);
+    first;
+
+    CheckTrue(Locate('id',vararrayof([5]),[]));
     CheckEquals(5,FieldByName('id').AsInteger);
     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);
     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;
     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;
 end;
 end;
 
 
@@ -2150,6 +2208,7 @@ begin
   else
   else
     dataset.fieldbyname('CALCFLD').AsInteger := 1;
     dataset.fieldbyname('CALCFLD').AsInteger := 1;
   end;
   end;
+  CheckTrue(DataSet.State=dsCalcFields, 'State');
 end;
 end;
 
 
 procedure TTestDBBasics.TestCalculatedField;
 procedure TTestDBBasics.TestCalculatedField;
@@ -2183,10 +2242,16 @@ begin
     CheckEquals(true,FieldByName('CALCFLD').isnull);
     CheckEquals(true,FieldByName('CALCFLD').isnull);
     next;
     next;
     CheckEquals(1234,FieldByName('CALCFLD').AsInteger);
     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;
     close;
     AFld1.Free;
     AFld1.Free;
     AFld2.Free;
     AFld2.Free;

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

@@ -57,7 +57,6 @@ type
     procedure TestNonNullableParams;
     procedure TestNonNullableParams;
     procedure TestDblQuoteEscComments;
     procedure TestDblQuoteEscComments;
     procedure TestpfInUpdateFlag; // bug 7565
     procedure TestpfInUpdateFlag; // bug 7565
-    procedure TestInt;
     procedure TestScript;
     procedure TestScript;
     procedure TestInsertReturningQuery;
     procedure TestInsertReturningQuery;
     procedure TestOpenStoredProc;
     procedure TestOpenStoredProc;
@@ -76,12 +75,13 @@ type
     procedure TestBlobSize;
     procedure TestBlobSize;
 
 
     procedure TestLargeRecordSize;
     procedure TestLargeRecordSize;
+    procedure TestInt;
     procedure TestNumeric;
     procedure TestNumeric;
     procedure TestFloat;
     procedure TestFloat;
+    procedure TestDate;
     procedure TestDateTime;       // bug 6925
     procedure TestDateTime;       // bug 6925
     procedure TestString;
     procedure TestString;
     procedure TestUnlVarChar;
     procedure TestUnlVarChar;
-    procedure TestDate;
 
 
     procedure TestNullValues;
     procedure TestNullValues;
     procedure TestParamQuery;
     procedure TestParamQuery;
@@ -231,30 +231,6 @@ begin
   end;
   end;
 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;
 procedure TTestFieldTypes.TestLargeRecordSize;
 
 
 begin
 begin
@@ -278,6 +254,56 @@ begin
     end;
     end;
 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;
 procedure TTestFieldTypes.TestNumeric;
 
 
@@ -356,6 +382,32 @@ begin
   end;
   end;
 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;
 procedure TTestFieldTypes.TestString;
 
 
@@ -486,6 +538,73 @@ 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.TestChangeBlob;
 procedure TTestFieldTypes.TestChangeBlob;
 
 
 var s : string;
 var s : string;
@@ -584,100 +703,6 @@ begin
     end;
     end;
 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;
 procedure TTestFieldTypes.TestNullValues;
 begin
 begin
   TSQLDBConnector(DBConnector).Connection.ExecuteDirect('create table FPDEV2 (FIELD1 INT, FIELD2 INT)');
   TSQLDBConnector(DBConnector).Connection.ExecuteDirect('create table FPDEV2 (FIELD1 INT, FIELD2 INT)');
@@ -1028,33 +1053,6 @@ 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.TestQueryAfterReconnect;
 procedure TTestFieldTypes.TestQueryAfterReconnect;
 var DS: TDataset;
 var DS: TDataset;
 begin
 begin
@@ -1186,7 +1184,7 @@ begin
 end;
 end;
 
 
 procedure TTestFieldTypes.TestStringLargerThen8192;
 procedure TTestFieldTypes.TestStringLargerThen8192;
-
+// See also: TestInsertLargeStrFields
 var
 var
   s             : string;
   s             : string;
   i             : integer;
   i             : integer;
@@ -1515,9 +1513,13 @@ begin
 end;
 end;
 
 
 procedure TTestFieldTypes.TestInsertLargeStrFields;
 procedure TTestFieldTypes.TestInsertLargeStrFields;
+// See also: TestStringLargerThen8192
 const
 const
-  FieldValue='test1';
+  FieldValue1='test1';
+var
+  FieldValue2: string;
 begin
 begin
+  FieldValue2:=StringOfChar('t', 16000);
   with TSQLDBConnector(DBConnector) do
   with TSQLDBConnector(DBConnector) do
     begin
     begin
     Connection.ExecuteDirect('create table FPDEV2 (  ' +
     Connection.ExecuteDirect('create table FPDEV2 (  ' +
@@ -1530,11 +1532,15 @@ begin
 
 
     query.sql.Text:='select * from FPDEV2';
     query.sql.Text:='select * from FPDEV2';
     Query.Open;
     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.ApplyUpdates;
     Query.Close;
     Query.Close;
     Query.Open;
     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;
     Query.Close;
     end;
     end;
 end;
 end;

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

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