* Accidentally comitted files, trying to apply patch from Ladislav Karrach to

   implement TFmtBCD fields, bug #16853. Has to be cleaned up later

git-svn-id: trunk@16948 -

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

@@ -549,7 +549,7 @@ procedure RegisterDatapacketReader(ADatapacketReaderClass : TDatapacketReaderCla
 
 implementation
 
-uses variants, dbconst;
+uses variants, dbconst, FmtBCD;
 
 Type TDatapacketReaderRegistration = record
                                        ReaderClass : TDatapacketReaderClass;
@@ -659,6 +659,18 @@ begin
     result := 0;
 end;
 
+function DBCompareBCD(subValue, aValue: pointer; options: TLocateOptions): LargeInt;
+begin
+  // A simple subtraction doesn't work, since it could be that the result
+  // doesn't fit into a LargeInt
+  if PBCD(subValue)^ < PBCD(aValue)^ then
+    result := -1
+  else if PBCD(subValue)^  > PBCD(aValue)^ then
+    result := 1
+  else
+    result := 0;
+end;
+
 procedure unSetFieldIsNull(NullMask : pbyte;x : longint); //inline;
 begin
   NullMask[x div 8] := (NullMask[x div 8]) and not (1 shl (x mod 8));
@@ -1503,6 +1515,7 @@ begin
     ftDateTime, ftDate, ftTime : ACompareRec.Comparefunc :=
       @DBCompareDouble;
     ftLargeint : ACompareRec.Comparefunc := @DBCompareLargeInt;
+    ftFmtBCD : ACompareRec.Comparefunc := @DBCompareBCD;
   else
     DatabaseErrorFmt(SErrIndexBasedOnInvField, [AField.FieldName,Fieldtypenames[AField.DataType]]);
   end;
@@ -1638,6 +1651,7 @@ begin
       ftword     : result := sizeof(longint);
     ftBoolean    : result := sizeof(wordbool);
     ftBCD        : result := sizeof(currency);
+    ftFmtBCD     : result := sizeof(TBCD);
     ftFloat,
       ftCurrency : result := sizeof(double);
     ftLargeInt   : result := sizeof(largeint);

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

@@ -901,8 +901,7 @@ begin
           if Required then Attributes := attributes + [faRequired];
           if ReadOnly then Attributes := attributes + [faReadOnly];
           if DataType = ftBCD then precision := (fields[i] as TBCDField).Precision
-          // this must change if TFMTBcdfield is implemented
-          else if DataType = ftFMTBcd then precision := (fields[i] as TBCDField).Precision;
+          else if DataType = ftFMTBcd then precision := (fields[i] as TFMTBCDField).Precision;
           end;
         end;
     finally

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

@@ -794,6 +794,48 @@ type
     property Size default 4;
   end;
 
+{ TFMTBCDField }
+
+  TFMTBCDField = class(TNumericField)
+  private
+    FMinValue,
+    FMaxValue   : TBCD;
+    FPrecision  : Longint;
+    FCurrency   : boolean;
+    function GetMaxValue: string;
+    function GetMinValue: string;
+    procedure SetMaxValue(const AValue: string);
+    procedure SetMinValue(const AValue: string);
+  protected
+    class procedure CheckTypeSize(AValue: Longint); override;
+    function GetAsBCD: TBCD; override;
+    function GetAsCurrency: Currency; override;
+    function GetAsFloat: Double; override;
+    function GetAsLongint: Longint; override;
+    function GetAsString: string; override;
+    function GetAsVariant: variant; override;
+    function GetDataSize: Integer; override;
+    function GetDefaultWidth: Longint; override;
+    procedure GetText(var TheText: string; ADisplayText: Boolean); override;
+    procedure SetAsBCD(const AValue: TBCD); override;
+    procedure SetAsFloat(AValue: Double); override;
+    procedure SetAsLongint(AValue: Longint); override;
+    procedure SetAsString(const AValue: string); override;
+    procedure SetAsCurrency(AValue: Currency); override;
+    procedure SetVarValue(const AValue: Variant); override;
+  public
+    constructor Create(AOwner: TComponent); override;
+    function CheckRange(AValue : TBCD) : Boolean;
+    property Value: TBCD read GetAsBCD write SetAsBCD;
+  published
+    property Precision: Longint read FPrecision write FPrecision default 15;
+    property Currency: Boolean read FCurrency write FCurrency;
+    property MaxValue: string read GetMaxValue write SetMaxValue;
+    property MinValue: string read GetMinValue write SetMinValue;
+    property Size default 4;
+  end;
+
+
 { TBlobField }
   TBlobStreamMode = (bmRead, bmWrite, bmReadWrite);
   TBlobType = ftBlob..ftWideMemo;
@@ -1833,7 +1875,7 @@ const
     varOleStr, varOleStr, varOleStr, varOleStr, varOleStr, varOleStr, varError,
     varOleStr, varOleStr, varError, varError, varError, varError, varError,
     varOleStr, varOleStr, varVariant, varUnknown, varDispatch, varOleStr,
-    varOleStr,varOleStr, varOleStr,varOleStr);
+    varOleStr, varDouble, varOleStr,varOleStr);
 
 
 Const
@@ -1942,7 +1984,7 @@ const
       { ftIDispatch} Nil,
       { ftGuid} TGuidField,
       { ftTimeStamp} Nil,
-      { ftFMTBcd} Nil,
+      { ftFMTBcd} TFMTBCDField,
       { ftFixedWideString} TWideStringField,
       { ftWideMemo} TWideMemoField
     );

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

@@ -109,10 +109,8 @@ begin
       TFloatField(Result).Precision:=FPrecision;
     if (Result is TBCDField) then
       TBCDField(Result).Precision:=FPrecision;
-    {Add when implemented:
     if (Result is TFmtBCDField) then
       TFmtBCDField(Result).Precision:=FPrecision;
-    }
   except
     Result.Free;
     Raise;
@@ -2395,6 +2393,184 @@ begin
 end;
 
 
+{ TFMTBCDField }
+
+class procedure TFMTBCDField.CheckTypeSize(AValue: Longint);
+begin
+  If AValue > MAXFMTBcdFractionSize then
+    DatabaseErrorfmt(SInvalidFieldSize,[AValue]);
+end;
+
+constructor TFMTBCDField.Create(AOwner: TComponent);
+begin
+  Inherited Create(AOwner);
+  FMaxValue := 0;
+  FMinValue := 0;
+  FValidChars := [DecimalSeparator, '+', '-', '0'..'9'];
+  SetDataType(ftFMTBCD);
+// Max.precision for NUMERIC,DECIMAL datatypes supported by some databases:
+//  Firebird-18; Oracle,SqlServer-38; MySQL-65; PostgreSQL-1000
+  Precision := 15; //default number of digits
+  Size:=4; //default number of digits after decimal place
+end;
+
+function TFMTBCDField.GetDataSize: Integer;
+begin
+  Result := sizeof(TBCD);
+end;
+
+function TFMTBCDField.GetDefaultWidth: Longint;
+begin
+  if Precision > 0 then Result := Precision+1
+  else Result := inherited GetDefaultWidth;
+end;
+
+function TFMTBCDField.GetAsBCD: TBCD;
+begin
+  if not GetData(@Result) then
+    Result := NullBCD;
+end;
+
+function TFMTBCDField.GetAsCurrency: Currency;
+var bcd: TBCD;
+begin
+  if GetData(@bcd) then
+    BCDToCurr(bcd, Result)
+  else
+    Result := 0;
+end;
+
+function TFMTBCDField.GetAsVariant: Variant;
+var bcd: TBCD;
+begin
+  If GetData(@bcd) then
+    Result := BCDToDouble(bcd)//remove when complete variant support in fmtbcd.pp will be implemented
+    //Result := VarFMTBcdCreate(bcd) //later invalid variant type cast ?
+  else
+    Result := Null;
+end;
+
+function TFMTBCDField.GetAsFloat: Double;
+var bcd: TBCD;
+begin
+  If GetData(@bcd) then
+    Result := BCDToDouble(bcd)
+  else
+    Result := 0;
+end;
+
+function TFMTBCDField.GetAsLongint: Longint;
+begin
+  Result := round(GetAsFloat);
+end;
+
+function TFMTBCDField.GetAsString: string;
+var bcd: TBCD;
+begin
+  If GetData(@bcd) then
+    Result:=BCDToStr(bcd)
+  else
+    Result:='';
+end;
+
+procedure TFMTBCDField.GetText(var TheText: string; ADisplayText: Boolean);
+var
+  bcd: TBCD;
+  E: double; //remove when formatBCD,BCDToStrF in fmtbcd.pp will be implemented
+  fmt: String;
+begin
+  if GetData(@bcd) then begin
+    E:=BCDToDouble(bcd);
+    if aDisplayText or (FEditFormat='') then
+      fmt := FDisplayFormat
+    else
+      fmt := FEditFormat;
+    if fmt<>'' then
+      TheText := FormatFloat(fmt,E)
+      //TheText := FormatBCD(fmt,bcd)
+    else if fCurrency then begin
+      if aDisplayText then
+        TheText := FloatToStrF(E, ffCurrency, FPrecision, 2{digits?})
+        //TheText := BcdToStrF(bcd, ffCurrency, FPrecision, 2{digits?})
+      else
+        TheText := FloatToStrF(E, ffFixed, FPrecision, 2{digits?});
+        //TheText := BcdToStrF(bcd, ffFixed, FPrecision, 2{digits?});
+    end else
+      TheText := BcdToStr(bcd);
+      //TheText := BcdToStrF(bcd, ffGeneral, FPrecision, FSize);
+  end else
+    TheText := '';
+end;
+
+function TFMTBCDField.GetMaxValue: string;
+begin
+  Result:=BCDToStr(FMaxValue);
+end;
+
+function TFMTBCDField.GetMinValue: string;
+begin
+  Result:=BCDToStr(FMinValue);
+end;
+
+procedure TFMTBCDField.SetMaxValue(const AValue: string);
+begin
+  FMaxValue:=StrToBCD(AValue);
+end;
+
+procedure TFMTBCDField.SetMinValue(const AValue: string);
+begin
+  FMinValue:=StrToBCD(AValue);
+end;
+
+Function TFMTBCDField.CheckRange(AValue: TBCD) : Boolean;
+begin
+  If (FMinValue<>0) or (FMaxValue<>0) then
+    Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
+  else
+    Result:=True;
+end;
+
+procedure TFMTBCDField.SetAsBCD(const AValue: TBCD);
+begin
+  if CheckRange(AValue) then
+    SetData(@AValue)
+  else
+    RangeError(AValue, BCDToDouble(FMinValue), BCDToDouble(FMaxValue));
+end;
+
+procedure TFMTBCDField.SetAsCurrency(AValue: Currency);
+var bcd: TBCD;
+begin
+  if CurrToBCD(AValue, bcd, 32, Size) then
+    SetAsBCD(bcd);
+end;
+
+procedure TFMTBCDField.SetVarValue(const AValue: Variant);
+var E:double;
+begin
+  E:=AValue;
+  SetAsBCD(DoubleToBCD(E));//remove when VarToBCD in fmtbcd.pp will be implemented
+  //SetAsBCD(VarToBCD(AValue));
+end;
+
+procedure TFMTBCDField.SetAsFloat(AValue: Double);
+begin
+  SetAsBCD(DoubleToBCD(AValue));
+end;
+
+
+procedure TFMTBCDField.SetAsLongint(AValue: Longint);
+begin
+  SetAsBCD(IntegerToBCD(AValue));
+end;
+
+
+procedure TFMTBCDField.SetAsString(const AValue: string);
+begin
+  SetAsBCD(StrToBCD(AValue));
+end;
+
+
 { TBlobField }
 
 Function TBlobField.GetBlobStream(Mode : TBlobStreamMode) : TStream;

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

@@ -99,7 +99,7 @@ Var
 implementation
 
 uses
-  dbconst, sysutils, dateutils;
+  dbconst, sysutils, dateutils,FmtBCD;
  
 type
 
@@ -395,6 +395,8 @@ begin
                   System.Delete(FD,1,fi);
                   fi:=pos(')',FD);
                   size1:=StrToIntDef(trim(copy(FD,1,fi-1)),255);
+                  if size1>4 then
+                    ft1 := ftFMTBcd;
                   end
                 else size1 := 4;
                 end;
@@ -507,6 +509,7 @@ begin
     ftBoolean  : pwordbool(buffer)^ := sqlite3_column_int(st,fnum)<>0;
     ftLargeInt : PInt64(buffer)^:= sqlite3_column_int64(st,fnum);
     ftBCD      : PCurrency(buffer)^:= FloattoCurr(sqlite3_column_double(st,fnum));
+    ftFmtBCD   : PBCD(buffer)^ := DoubleToBCD(sqlite3_column_double(st,fnum));
     ftFloat,
     ftCurrency : pdouble(buffer)^:= sqlite3_column_double(st,fnum);
     ftDateTime,

packages/fcl-db/tests/dbtestframework.pas

@@ -18,9 +18,10 @@ uses
   SdfDSToolsUnit,
 // Units wich contains the tests
   testbasics,
+  testdbbasics,
   testfieldtypes,
   TestDatasources,
-  testdbbasics,
+  //  testdbbasics,
   TestBufDatasetStreams;
 
 var

packages/fcl-db/tests/sqldbtoolsunit.pas

@@ -54,7 +54,7 @@ const MySQLdbTypes = [mysql40,mysql41,mysql50];
           '',
           '',
           'TIMESTAMP',
-          '',
+          'NUMERIC(18,6)',
           '',
           ''
         );

packages/fcl-db/tests/testdbbasics.pas

@@ -27,6 +27,11 @@ type
     procedure TearDown; override;
   published
     procedure TestCancelUpdDelete1;
+
+
+    procedure TestSupportfmtBCDFields;
+
+
     procedure TestCancelUpdDelete2;
     procedure TestAppendInsertRecord;
     procedure TestBookmarks;
@@ -56,6 +61,7 @@ type
     procedure TestSupportDateFields;
     procedure TestSupportCurrencyFields;
     procedure TestSupportBCDFields;
+    //    procedure TestSupportfmtBCDFields;
     procedure TestSupportFixedStringFields;
 
     procedure TestAppendOnEmptyDataset;
@@ -1953,6 +1959,24 @@ begin
   ds.close;
 end;
 
+procedure TTestDBBasics.TestSupportfmtBCDFields;
+var i          : byte;
+    ds         : TDataset;
+    Fld        : TField;
+
+begin
+  TestfieldDefinition(ftFMTBcd,8,ds,Fld);
+
+  for i := 0 to testValuesCount-1 do
+    begin
+    AssertEquals(CurrToStr(testCurrencyValues[i]),Fld.AsString);
+    AssertEquals(testCurrencyValues[i],Fld.AsCurrency);
+    AssertEquals(testCurrencyValues[i],Fld.AsFloat);
+    ds.Next;
+    end;
+  ds.close;
+end;
+
 procedure TTestDBBasics.TestSupportFixedStringFields;
 var i          : byte;
     ds         : TDataset;