View Issue Details

IDProjectCategoryView StatusLast Update
0026068FPCDatabasepublic2018-05-17 14:55
ReporterBranislavAssigned ToBigChimp 
PrioritynormalSeverityminorReproducibilityalways
Status closedResolutionfixed 
PlatformWin32OSWindowsOS VersionWindows 7
Product VersionProduct Build44758 
Target Version3.0.0Fixed in Version3.0.0 
Summary0026068: FPC 2.6.4 and Firebird
Description1. Commiting string value to Firebird 2.5 field varchar (9876) writes down just first string.
2. On project exiting event rises an error if Transaction.Active is set to false and Connection.Connected is set to false.

Same example works (don't make errors and writes whole strings) with Lazarus 1.2.2 (44758) with FPC 2.6.2.
Steps To ReproduceJust compile Example in attachment with :
 - Lazarus 1.2.2 (44758) with FPC 2.6.4 - errors present
 - Lazarus 1.2.2 (44758) with FPC 2.6.2 - everything is ok
TagsDatabase, dbtestframework, Firebird, mysql, postgres
Fixed in Revision27691 27717 27738
FPCOldBugId
FPCTarget
Attached Files
  • FirebirdTest.zip (174,632 bytes)
  • fields.inc (68,067 bytes)
    {
        This file is part of the Free Pascal run time library.
        Copyright (c) 1999-2000 by Michael Van Canneyt, member of the
        Free Pascal development team
    
        TFields and related components implementations.
    Note: this file includes partial fixes for bug http://bugs.freepascal.org/view.php?id=26068
        See the file COPYING.FPC, included in this distribution,
        for details about the copyright.
    
        This program is distributed in the hope that it will be useful,
        but WITHOUT ANY WARRANTY; without even the implied warranty of
        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
    
     **********************************************************************}
    {Procedure DumpMem (P : Pointer;Size : Longint);
    
    Var i : longint;
    
    begin
      Write ('Memory dump : ');
      For I:=0 to Size-1 do
        Write (Pbyte(P)[i],' ');
      Writeln;
    end;}
    
    { ---------------------------------------------------------------------
        TFieldDef
      ---------------------------------------------------------------------}
    
    Constructor TFieldDef.Create(ACollection : TCollection);
    
    begin
      Inherited create(ACollection);
      FFieldNo:=Index+1;
    end;
    
    Constructor TFieldDef.Create(AOwner: TFieldDefs; const AName: string;
          ADataType: TFieldType; ASize: Integer; ARequired: Boolean; AFieldNo: Longint);
    
    begin
    {$ifdef dsdebug }
      Writeln('TFieldDef.Create : ',Aname,'(',AFieldNo,')');
    {$endif}
      Inherited Create(AOwner);
      Name:=Aname;
      FDatatype:=ADatatype;
      FSize:=ASize;
      FRequired:=ARequired;
      FPrecision:=-1;
      FFieldNo:=AFieldNo;
    end;
    
    Destructor TFieldDef.Destroy;
    
    begin
      Inherited destroy;
    end;
    
    procedure TFieldDef.Assign(APersistent: TPersistent);
    var fd: TFieldDef;
    begin
      fd := nil;
      if APersistent is TFieldDef then
        fd := APersistent as TFieldDef;
      if Assigned(fd) then begin
        Collection.BeginUpdate;
        try
          Name := fd.Name;
          DataType := fd.DataType;
          Size := fd.Size;
          Precision := fd.Precision;
          FRequired := fd.Required;
        finally
          Collection.EndUpdate;
        end;
      end else
      inherited Assign(APersistent);
    end;
    
    Function TFieldDef.CreateField(AOwner: TComponent): TField;
    
    Var TheField : TFieldClass;
    
    begin
    {$ifdef dsdebug}
      Writeln ('Creating field '+FNAME);
    {$endif dsdebug}
      TheField:=GetFieldClass;
      if TheField=Nil then
        DatabaseErrorFmt(SUnknownFieldType,[FName]);
      Result:=Thefield.Create(AOwner);
      Try
        Result.Size:=FSize;
        Result.Required:=FRequired;
        Result.FFieldName:=FName;
        Result.FDisplayLabel:=DisplayName;
        Result.FFieldNo:=Self.FieldNo;
        Result.SetFieldType(DataType);
        Result.FReadOnly:= (faReadOnly in Attributes);
    {$ifdef dsdebug}
        Writeln ('TFieldDef.CReateField : Trying to set dataset');
    {$endif dsdebug}
    {$ifdef dsdebug}
        Writeln ('TFieldDef.CReateField : Result Fieldno : ',Result.FieldNo,' Self : ',FieldNo);
    {$endif dsdebug}
        Result.Dataset:=TFieldDefs(Collection).Dataset;
        If (Result is TFloatField) then
          TFloatField(Result).Precision:=FPrecision;
        if (Result is TBCDField) then
          TBCDField(Result).Precision:=FPrecision;
        if (Result is TFmtBCDField) then
          TFmtBCDField(Result).Precision:=FPrecision;
      except
        Result.Free;
        Raise;
      end;
    
    end;
    
    procedure TFieldDef.SetAttributes(AValue: TFieldAttributes);
    begin
      FAttributes := AValue;
      Changed(False);
    end;
    
    procedure TFieldDef.SetDataType(AValue: TFieldType);
    begin
      FDataType := AValue;
      Changed(False);
    end;
    
    procedure TFieldDef.SetPrecision(const AValue: Longint);
    begin
      FPrecision := AValue;
      Changed(False);
    end;
    
    procedure TFieldDef.SetSize(const AValue: Integer);
    begin
      FSize := AValue;
      Changed(False);
    end;
    
    procedure TFieldDef.SetRequired(const AValue: Boolean);
    begin
      FRequired := AValue;
      Changed(False);
    end;
    
    Function TFieldDef.GetFieldClass : TFieldClass;
    
    begin
      //!! Should be owner as tdataset but that doesn't work ??
    
      If Assigned(Collection) And
         (Collection is TFieldDefs) And
         Assigned(TFieldDefs(Collection).Dataset) then
        Result:=TFieldDefs(Collection).Dataset.GetFieldClass(FDataType)
      else
        Result:=Nil;
    end;
    
    { ---------------------------------------------------------------------
        TFieldDefs
      ---------------------------------------------------------------------}
    
    {
    destructor TFieldDefs.Destroy;
    
    begin
      FItems.Free;
      // This will destroy all fielddefs since we own them...
      Inherited Destroy;
    end;
    }
    
    procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType);
    
    begin
      Add(AName,ADatatype,0,False);
    end;
    
    procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize : Word);
    
    begin
      Add(AName,ADatatype,ASize,False);
    end;
    
    procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word;
      ARequired: Boolean);
    
    begin
      If Length(AName)=0 Then
        DatabaseError(SNeedFieldName);
      // the fielddef will register itself here as a owned component.
      // fieldno is 1 based !
      BeginUpdate;
      try
        TFieldDef.Create(Self,AName,ADataType,ASize,Arequired,Count+1);
      finally
        EndUpdate;
      end;
    end;
    
    function TFieldDefs.GetItem(Index: Longint): TFieldDef;
    
    begin
      Result := TFieldDef(inherited Items[Index]);
    end;
    
    procedure TFieldDefs.SetItem(Index: Longint; const AValue: TFieldDef);
    begin
      inherited Items[Index] := AValue;
    end;
    
    constructor TFieldDefs.Create(ADataset: TDataset);
    begin
      Inherited Create(ADataset, Owner, TFieldDef);
    end;
    
    procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
    
    Var I : longint;
    
    begin
      Clear;
      For i:=0 to FieldDefs.Count-1 do
        With FieldDefs[i] do
          Add(Name,DataType,Size,Required);
    end;
    
    function TFieldDefs.Find(const AName: string): TFieldDef;
    begin
      Result := (Inherited Find(AName)) as TFieldDef;
      if Result=nil then DatabaseErrorFmt(SFieldNotFound,[AName],FDataset);
    end;
    
    {
    procedure TFieldDefs.Clear;
    
    Var I : longint;
    
    begin
      For I:=FItems.Count-1 downto 0 do
        TFieldDef(Fitems[i]).Free;
      FItems.Clear;
    end;
    }
    
    procedure TFieldDefs.Update;
    
    begin
      if not Updated then
        begin
        If Assigned(Dataset) then
          DataSet.InitFieldDefs;
        Updated := True;
        end;
    end;
    
    function TFieldDefs.MakeNameUnique(const AName: String): string;
    var DblFieldCount : integer;
    begin
      DblFieldCount := 0;
      Result := AName;
      while assigned(inherited Find(Result)) do
        begin
        inc(DblFieldCount);
        Result := AName + '_' + IntToStr(DblFieldCount);
        end;
    end;
    
    Function TFieldDefs.AddFieldDef : TFieldDef;
    
    begin
      Result:=TFieldDef.Create(Self,'',ftUnknown,0,False,Count+1);
    end;
    
    { ---------------------------------------------------------------------
        TField
      ---------------------------------------------------------------------}
    
    Const
      SBCD = 'BCD';
      SBoolean = 'Boolean';
      SDateTime = 'TDateTime';
      SFloat = 'Float';
      SInteger = 'Integer';
      SLargeInt = 'LargeInt';
      SVariant = 'Variant';
      SString = 'String';
      SBytes = 'Bytes';
    
    constructor TField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      FVisible:=True;
      FValidChars:=[#0..#255];
    
      FProviderFlags := [pfInUpdate,pfInWhere];
    end;
    
    destructor TField.Destroy;
    
    begin
      IF Assigned(FDataSet) then
        begin
        FDataSet.Active:=False;
        if Assigned(FFields) then
          FFields.Remove(Self);
        end;
      FLookupList.Free;
      Inherited Destroy;
    end;
    
    function TField.AccessError(const TypeName: string): EDatabaseError;
    
    begin
      Result:=EDatabaseError.CreateFmt(SinvalidTypeConversion,[TypeName,FFieldName]);
    end;
    
    procedure TField.Assign(Source: TPersistent);
    
    begin
      if Source = nil then Clear
      else if Source is TField then begin
        Value := TField(Source).Value;
      end else
        inherited Assign(Source);
    end;
    
    procedure TField.AssignValue(const AValue: TVarRec);
      procedure Error;
      begin
        DatabaseErrorFmt(SFieldValueError, [DisplayName]);
      end;
    
    begin
      with AValue do
        case VType of
          vtInteger:
            AsInteger := VInteger;
          vtBoolean:
            AsBoolean := VBoolean;
          vtChar:
            AsString := VChar;
          vtExtended:
            AsFloat := VExtended^;
          vtString:
            AsString := VString^;
          vtPointer:
            if VPointer <> nil then Error;
          vtPChar:
            AsString := VPChar;
          vtObject:
            if (VObject = nil) or (VObject is TPersistent) then
              Assign(TPersistent(VObject))
            else
              Error;
          vtAnsiString:
            AsString := string(VAnsiString);
          vtCurrency:
            AsCurrency := VCurrency^;
          vtVariant:
            if not VarIsClear(VVariant^) then Self.Value := VVariant^;
          vtWideString:
            AsWideString := WideString(VWideString);
          vtInt64:
            AsLargeInt := VInt64^;
        else
          Error;
        end;
    end;
    
    procedure TField.Change;
    
    begin
      If Assigned(FOnChange) Then
        FOnChange(Self);
    end;
    
    procedure TField.CheckInactive;
    
    begin
      If Assigned(FDataSet) then
        FDataset.CheckInactive;
    end;
    
    procedure TField.Clear;
    
    begin
      if FieldKind in [fkData, fkInternalCalc] then
        SetData(Nil);
    end;
    
    procedure TField.DataChanged;
    
    begin
      FDataset.DataEvent(deFieldChange,ptrint(Self));
    end;
    
    procedure TField.FocusControl;
    var
      Field1: TField;
    begin
      Field1 := Self;
      FDataSet.DataEvent(deFocusControl,ptrint(@Field1));
    end;
    
    procedure TField.FreeBuffers;
    
    begin
      // Empty. Provided for backward compatibiliy;
      // TDataset manages the buffers.
    end;
    
    function TField.GetAsBCD: TBCD;
    begin
      raise AccessError(SBCD);
    end;
    
    function TField.GetAsBoolean: Boolean;
    begin
      raise AccessError(SBoolean);
    end;
    
    function TField.GetAsBytes: TBytes;
    begin
      SetLength(Result, DataSize);
      if assigned(result) and not GetData(@Result[0], False) then
        Result := nil;
    end;
    
    function TField.GetAsDateTime: TDateTime;
    
    begin
      raise AccessError(SdateTime);
    end;
    
    function TField.GetAsFloat: Double;
    
    begin
      raise AccessError(SDateTime);
    end;
    
    function TField.GetAsLongint: Longint;
    
    begin
      Result:=GetAsInteger;
    end;
    
    function TField.GetAsInteger: Longint;
    
    begin
      raise AccessError(SInteger);
    end;
    
    function TField.GetAsVariant: Variant;
    
    begin
      raise AccessError(SVariant);
    end;
    
    
    function TField.GetAsString: string;
    
    begin
      Result := GetClassDesc;
    end;
    
    function TField.GetAsWideString: WideString;
    begin
      Result := GetAsString;
    end;
    
    function TField.GetOldValue: Variant;
    
    var SaveState : TDatasetState;
    
    begin
      SaveState := FDataset.State;
      try
        FDataset.SetTempState(dsOldValue);
        Result := GetAsVariant;
      finally
        FDataset.RestoreState(SaveState);
      end;
    end;
    
    function TField.GetNewValue: Variant;
    
    var SaveState : TDatasetState;
    
    begin
      SaveState := FDataset.State;
      try
        FDataset.SetTempState(dsNewValue);
        Result := GetAsVariant;
      finally
        FDataset.RestoreState(SaveState);
      end;
    end;
    
    procedure TField.SetNewValue(const AValue: Variant);
    
    var SaveState : TDatasetState;
    
    begin
      SaveState := FDataset.State;
      try
        FDataset.SetTempState(dsNewValue);
        SetAsVariant(AValue);
      finally
        FDataset.RestoreState(SaveState);
      end;
    end;
    
    function TField.GetCurValue: Variant;
    
    var SaveState : TDatasetState;
    
    begin
      SaveState := FDataset.State;
      try
        FDataset.SetTempState(dsCurValue);
        Result := GetAsVariant;
      finally
        FDataset.RestoreState(SaveState);
      end;
    end;
    
    function TField.GetCanModify: Boolean;
    
    begin
      Result:=Not ReadOnly;
      If Result then
        begin
        Result := FieldKind in [fkData, fkInternalCalc];
        if Result then
          begin
          Result:=Assigned(DataSet) and Dataset.Active;
          If Result then
            Result:= DataSet.CanModify;
          end;
        end;
    end;
    
    function TField.GetClassDesc: String;
    var ClassN : string;
    begin
      ClassN := copy(ClassName,2,pos('Field',ClassName)-2);
      if isNull then
        result := '(' + LowerCase(ClassN) + ')'
       else
        result := '(' + UpperCase(ClassN) + ')';
    end;
    
    function TField.GetData(Buffer: Pointer): Boolean;
    
    begin
      Result:=GetData(Buffer,True);
    end;
    
    function TField.GetData(Buffer: Pointer; NativeFormat : Boolean): Boolean;
    
    begin
      IF FDataset=Nil then
        DatabaseErrorFmt(SNoDataset,[FieldName]);
      If FVAlidating then
        begin
        result:=assigned(FValueBuffer);
        If Result and assigned(Buffer) then
          Move (FValueBuffer^,Buffer^ ,DataSize);
        end
      else
        Result:=FDataset.GetFieldData(Self,Buffer,NativeFormat);
    end;
    
    function TField.GetDataSize: Integer;
    
    begin
      Result:=0;
    end;
    
    function TField.GetDefaultWidth: Longint;
    
    begin
      Result:=10;
    end;
    
    function TField.GetDisplayName  : String;
    
    begin
      If FDisplayLabel<>'' then
        result:=FDisplayLabel
      else
        Result:=FFieldName;
    end;
    
    Function TField.IsDisplayStored : Boolean;
    
    begin
      Result:=(DisplayLabel<>FieldName);
    end;
    
    function TField.GetLookupList: TLookupList;
    begin
      if not Assigned(FLookupList) then
        FLookupList := TLookupList.Create;
      Result := FLookupList;
    end;
    
    procedure TField.CalcLookupValue;
    begin
      if FLookupCache then
        Value := LookupList.ValueOfKey(FDataSet.FieldValues[FKeyFields])
      else if Assigned(FLookupDataSet) and FDataSet.Active then
        Value := FLookupDataSet.Lookup(FLookupKeyfields, FDataSet.FieldValues[FKeyFields], FLookupresultField);
    end;
    
    function TField.getIndex : longint;
    
    begin
      If Assigned(FDataset) then
        Result:=FDataset.FFieldList.IndexOf(Self)
      else
        Result:=-1;
    end;
    
    function TField.GetLookup: Boolean;
    begin
      Result := FieldKind = fkLookup;
    end;
    
    function TField.GetAsLargeInt: LargeInt;
    begin
      Raise AccessError(SLargeInt);
    end;
    
    function TField.GetAsCurrency: Currency;
    begin
      Result := GetAsFloat;
    end;
    
    procedure TField.SetAlignment(const AValue: TAlignMent);
    begin
      if FAlignment <> AValue then
        begin
        FAlignment := AValue;
        PropertyChanged(false);
        end;
    end;
    
    procedure TField.SetIndex(const AValue: Integer);
    begin
      if FFields <> nil then FFields.SetFieldIndex(Self, AValue)
    end;
    
    procedure TField.SetAsCurrency(AValue: Currency);
    begin
      SetAsFloat(AValue);
    end;
    
    function TField.GetIsNull: Boolean;
    
    begin
      Result:=Not(GetData (Nil));
    end;
    
    function TField.GetParentComponent: TComponent;
    
    begin
      Result := DataSet;
    end;
    
    procedure TField.GetText(var AText: string; ADisplayText: Boolean);
    
    begin
      AText:=GetAsString;
    end;
    
    function TField.HasParent: Boolean;
    
    begin
      HasParent:=True;
    end;
    
    function TField.IsValidChar(InputChar: Char): Boolean;
    
    begin
      // FValidChars must be set in Create.
      Result:=InputChar in FValidChars;
    end;
    
    procedure TField.RefreshLookupList;
    var
      tmpActive: Boolean;
    begin
      if not Assigned(FLookupDataSet) or (Length(FLookupKeyfields) = 0)
      or (Length(FLookupresultField) = 0) or (Length(FKeyFields) = 0) then
        Exit;
        
      tmpActive := FLookupDataSet.Active;
      try
        FLookupDataSet.Active := True;
        FFields.CheckFieldNames(FKeyFields);
        FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
        FLookupDataset.FieldByName(FLookupResultField); // I presume that if it doesn't exist it throws exception, and that a field with null value is still valid
        LookupList.Clear; // have to be F-less because we might be creating it here with getter!
    
        FLookupDataSet.DisableControls;
        try
          FLookupDataSet.First;
          while not FLookupDataSet.Eof do
          begin
            FLookupList.Add(FLookupDataSet.FieldValues[FLookupKeyfields], FLookupDataSet.FieldValues[FLookupResultField]);
            FLookupDataSet.Next;
          end;
        finally
          FLookupDataSet.EnableControls;
        end;
      finally
        FLookupDataSet.Active := tmpActive;
      end;
    end;
    
    procedure TField.Notification(AComponent: TComponent; Operation: TOperation);
    
    begin
      Inherited Notification(AComponent,Operation);
      if (Operation = opRemove) and (AComponent = FLookupDataSet) then
        FLookupDataSet := nil;
    end;
    
    procedure TField.PropertyChanged(LayoutAffected: Boolean);
    
    begin
      If (FDataset<>Nil) and (FDataset.Active) then
        If LayoutAffected then
          FDataset.DataEvent(deLayoutChange,0)
        else
          FDataset.DataEvent(deDatasetchange,0);
    end;
    
    procedure TField.ReadState(Reader: TReader);
    
    begin
      inherited ReadState(Reader);
      if Reader.Parent is TDataSet then
        DataSet := TDataSet(Reader.Parent);
    end;
    
    procedure TField.SetAsBCD(const AValue: TBCD);
    begin
      Raise AccessError(SBCD);
    end;
    
    procedure TField.SetAsBytes(const AValue: TBytes);
    begin
      raise AccessError(SBytes);
    end;
    
    procedure TField.SetAsBoolean(AValue: Boolean);
    
    begin
      Raise AccessError(SBoolean);
    end;
    
    procedure TField.SetAsDateTime(AValue: TDateTime);
    
    begin
      Raise AccessError(SDateTime);
    end;
    
    procedure TField.SetAsFloat(AValue: Double);
    
    begin
      Raise AccessError(SFloat);
    end;
    
    procedure TField.SetAsVariant(const AValue: Variant);
    
    begin
      if VarIsNull(AValue) then
        Clear
      else
        try
          SetVarValue(AValue);
        except
          on EVariantError do DatabaseErrorFmt(SFieldValueError, [DisplayName]);
        end;
    end;
    
    
    procedure TField.SetAsLongint(AValue: Longint);
    
    begin
      SetAsInteger(AValue);
    end;
    
    procedure TField.SetAsInteger(AValue: Longint);
    
    begin
      raise AccessError(SInteger);
    end;
    
    procedure TField.SetAsLargeint(AValue: Largeint);
    begin
      Raise AccessError(SLargeInt);
    end;
    
    procedure TField.SetAsString(const AValue: string);
    
    begin
      Raise AccessError(SString);
    end;
    
    procedure TField.SetAsWideString(const AValue: WideString);
    begin
      SetAsString(AValue);
    end;
    
    
    procedure TField.SetData(Buffer: Pointer);
    
    begin
     SetData(Buffer,True);
    end;
    
    procedure TField.SetData(Buffer: Pointer; NativeFormat : Boolean);
    
    begin
      If Not Assigned(FDataset) then
        DatabaseErrorFmt(SNoDataset,[FieldName]);
      FDataSet.SetFieldData(Self,Buffer, NativeFormat);
    end;
    
    Procedure TField.SetDataset (AValue : TDataset);
    
    begin
    {$ifdef dsdebug}
      Writeln ('Setting dataset');
    {$endif}
      If AValue=FDataset then exit;
      If Assigned(FDataset) Then
        begin
        FDataset.CheckInactive;
        FDataset.FFieldList.Remove(Self);
        end;
      If Assigned(AValue) then
        begin
        AValue.CheckInactive;
        AValue.FFieldList.Add(Self);
        end;
      FDataset:=AValue;
    end;
    
    procedure TField.SetDataType(AValue: TFieldType);
    
    begin
      FDataType := AValue;
    end;
    
    procedure TField.SetFieldType(AValue: TFieldType);
    
    begin
      { empty }
    end;
    
    procedure TField.SetParentComponent(AParent: TComponent);
    
    begin
      if not (csLoading in ComponentState) then
        DataSet := AParent as TDataSet;
    end;
    
    procedure TField.SetSize(AValue: Integer);
    
    begin
      CheckInactive;
      CheckTypeSize(AValue);
      FSize:=AValue;
    end;
    
    procedure TField.SetText(const AValue: string);
    
    begin
      AsString:=AValue;
    end;
    
    procedure TField.SetVarValue(const AValue: Variant);
    begin
      Raise AccessError(SVariant);
    end;
    
    procedure TField.Validate(Buffer: Pointer);
    
    begin
      If assigned(OnValidate) Then
        begin
        FValueBuffer:=Buffer;
        FValidating:=True;
        Try
          OnValidate(Self);
        finally
          FValidating:=False;
        end;
        end;
    end;
    
    class function Tfield.IsBlob: Boolean;
    
    begin
      Result:=False;
    end;
    
    class procedure TField.CheckTypeSize(AValue: Longint);
    
    begin
      If (AValue<>0) and Not IsBlob Then
        DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
    end;
    
    // TField private methods
    
    procedure TField.SetEditText(const AValue: string);
    begin
      if Assigned(OnSetText) then
        OnSetText(Self, AValue)
      else
        SetText(AValue);
    end;
    
    function TField.GetEditText: String;
    begin
      SetLength(Result, 0);
      if Assigned(OnGetText) then
        OnGetText(Self, Result, False)
      else
        GetText(Result, False);
    end;
    
    function TField.GetDisplayText: String;
    begin
      SetLength(Result, 0);
      if Assigned(OnGetText) then
        OnGetText(Self, Result, True)
      else
        GetText(Result, True);
    end;
    
    procedure TField.SetDisplayLabel(const AValue: string);
    begin
      if FDisplayLabel<>AValue then
        begin
        FDisplayLabel:=AValue;
        PropertyChanged(true);
        end;
    end;
    
    procedure TField.SetDisplayWidth(const AValue: Longint);
    begin
      if FDisplayWidth<>AValue then
        begin
        FDisplayWidth:=AValue;
        PropertyChanged(True);
        end;
    end;
    
    function TField.GetDisplayWidth: integer;
    begin
      if FDisplayWidth=0 then
        result:=GetDefaultWidth
      else
        result:=FDisplayWidth;
    end;
    
    procedure TField.SetLookup(const AValue: Boolean);
    const
      ValueToLookupMap: array[Boolean] of TFieldKind = (fkData, fkLookup);
    begin
      FieldKind := ValueToLookupMap[AValue];
    end;
    
    procedure TField.SetReadOnly(const AValue: Boolean);
    begin
      if (FReadOnly<>AValue) then
        begin
        FReadOnly:=AValue;
        PropertyChanged(True);
        end;
    end;
    
    procedure TField.SetVisible(const AValue: Boolean);
    begin
      if FVisible<>AValue then
        begin
        FVisible:=AValue;
        PropertyChanged(True);
        end;
    end;
    
    
    { ---------------------------------------------------------------------
        TStringField
      ---------------------------------------------------------------------}
    
    
    constructor TStringField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDataType(ftString);
      FFixedChar := False;
      FTransliterate := False;
      FSize:=20;
    end;
    
    procedure TStringField.SetFieldType(AValue: TFieldType);
    begin
      if avalue in [ftString, ftFixedChar] then
        SetDataType(AValue);
    end;
    
    class procedure TStringField.CheckTypeSize(AValue: Longint);
    
    begin
    // A size of 0 is allowed, since for example Firebird allows
    // a query like: 'select '' as fieldname from table' which
    // results in a string with size 0.
      If (AValue<0) Then
        databaseErrorFmt(SInvalidFieldSize,[AValue])
    end;
    
    function TStringField.GetAsBoolean: Boolean;
    
    Var S : String;
    
    begin
      S:=GetAsString;
      result := (Length(S)>0) and (Upcase(S[1]) in ['T',YesNoChars[True]]);
    end;
    
    function TStringField.GetAsDateTime: TDateTime;
    
    begin
      Result:=StrToDateTime(GetAsString);
    end;
    
    function TStringField.GetAsFloat: Double;
    
    begin
      Result:=StrToFloat(GetAsString);
    end;
    
    function TStringField.GetAsInteger: Longint;
    
    begin
      Result:=StrToInt(GetAsString);
    end;
    
    function TStringField.GetAsString: string;
    
    begin
      If Not GetValue(Result) then
        Result:='';
    end;
    
    function TStringField.GetAsVariant: Variant;
    
    Var s : string;
    
    begin
      If GetValue(s) then
        Result:=s
      else
        Result:=Null;
    end;
    
    
    function TStringField.GetDataSize: Integer;
    
    begin
      Result:=Size+1;
    end;
    
    function TStringField.GetDefaultWidth: Longint;
    
    begin
      result:=Size;
    end;
    
    Procedure TStringField.GetText(var AText: string; ADisplayText: Boolean);
    
    begin
        AText:=GetAsString;
    end;
    
    function TStringField.GetValue(var AValue: string): Boolean;
    
    Var Buf, TBuf : TStringFieldBuffer;
        DynBuf, TDynBuf : Array of char;
    
    begin
      if DataSize <= dsMaxStringSize then
        begin
        Result:=GetData(@Buf);
        Buf[Size]:=#0;  //limit string to Size
        If Result then
          begin
          if Transliterate then
            begin
            DataSet.Translate(Buf,TBuf,False);
            AValue:=TBuf;
            end
          else
            AValue:=Buf
          end
        end
      else
        begin
        SetLength(DynBuf,DataSize);
        Result:=GetData(@DynBuf[0]);
        DynBuf[Size]:=#0;  //limit string to Size
        If Result then
          begin
          if Transliterate then
            begin
            SetLength(TDynBuf,DataSize);
            DataSet.Translate(@DynBuf[0],@TDynBuf[0],False);
            AValue:=pchar(TDynBuf);
            end
          else
            AValue:=pchar(DynBuf);
          end
        end;
    end;
    
    procedure TStringField.SetAsBoolean(AValue: Boolean);
    
    begin
      If AValue Then
        SetAsString('T')
      else
        SetAsString('F');
    end;
    
    procedure TStringField.SetAsDateTime(AValue: TDateTime);
    
    begin
      SetAsString(DateTimeToStr(AValue));
    end;
    
    procedure TStringField.SetAsFloat(AValue: Double);
    
    begin
      SetAsString(FloatToStr(AValue));
    end;
    
    procedure TStringField.SetAsInteger(AValue: Longint);
    
    begin
      SetAsString(intToStr(AValue));
    end;
    
    procedure TStringField.SetAsString(const AValue: string);
    
    var Buf      : TStringFieldBuffer;
        DynBuf   : array of char;
    
    begin
      if Length(AValue)=0 then
        begin
        Buf := #0;
        SetData(@Buf);
        end
      else if DataSize <= dsMaxStringSize then
        begin
        if FTransliterate then
          DataSet.Translate(@AValue[1],Buf,True)
        else
          // The data is copied into the buffer, since some TDataset descendents copy
          // the whole buffer-length in SetData. (See bug 8477)
          StrPLCopy(PChar(Buf), AValue, Size); //Buf := AValue; backported FPC trunk revision 27717
        // If length(AValue) > DataSize the buffer isn't terminated properly
        Buf[DataSize-1] := #0;
        SetData(@Buf);
        end
      else
        begin
        SetLength(DynBuf, DataSize);
        if FTransliterate then
          DataSet.Translate(@AValue[1],@DynBuf[0],True)
        else
          StrPLCopy(PChar(DynBuf), AValue, Size); //StrPLCopy(@DynBuf[0], AValue, DataSize); Backported FPC trunk revision 27691,27717 
        SetData(@DynBuf[0]);
        end
    end;
    
    procedure TStringField.SetVarValue(const AValue: Variant);
    begin
      SetAsString(AValue);
    end;
    
    { ---------------------------------------------------------------------
        TWideStringField
      ---------------------------------------------------------------------}
    
    class procedure TWideStringField.CheckTypeSize(AValue: Integer);
    begin
    // A size of 0 is allowed, since for example Firebird allows
    // a query like: 'select '' as fieldname from table' which
    // results in a string with size 0.
      If (AValue<0) Then
        databaseErrorFmt(SInvalidFieldSize,[AValue]);
    end;
    
    constructor TWideStringField.Create(AOwner: TComponent);
    begin
      inherited Create(AOwner);
      SetDataType(ftWideString);
    end;
    
    procedure TWideStringField.SetFieldType(AValue: TFieldType);
    begin
      if avalue in [ftWideString, ftFixedWideChar] then
        SetDataType(AValue);
    end;
    
    function TWideStringField.GetValue(var AValue: WideString): Boolean;
    var
      FixBuffer : array[0..dsMaxStringSize div 2] of WideChar;
      DynBuffer : array of WideChar;
      Buffer    : PWideChar;
    begin
      if DataSize <= dsMaxStringSize then begin
        Result := GetData(@FixBuffer, False);
        FixBuffer[Size]:=#0;     //limit string to Size
        AValue := FixBuffer;
      end else begin
        SetLength(DynBuffer, Succ(Size));
        Buffer := PWideChar(DynBuffer);
        Result := GetData(Buffer, False);
        Buffer[Size]:=#0;     //limit string to Size
        if Result then
          AValue := Buffer;
      end;
    end;
    
    function TWideStringField.GetAsString: string;
    begin
      Result := GetAsWideString;
    end;
    
    procedure TWideStringField.SetAsString(const AValue: string);
    begin
      SetAsWideString(AValue);
    end;
    
    function TWideStringField.GetAsVariant: Variant;
    var
      ws: WideString;
    begin
      if GetValue(ws) then
        Result := ws
      else
        Result := Null;
    end;
    
    procedure TWideStringField.SetVarValue(const AValue: Variant);
    begin
      SetAsWideString(AValue);
    end;
    
    function TWideStringField.GetAsWideString: WideString;
    begin
      if not GetValue(Result) then
        Result := '';
    end;
    
    procedure TWideStringField.SetAsWideString(const AValue: WideString);
    const
      NullWideChar : WideChar = #0;
    var
      Buffer : PWideChar;
    begin
      if Length(AValue)>0 then
        Buffer := PWideChar(@AValue[1])
      else
        Buffer := @NullWideChar;
      SetData(Buffer, False);
    end;
    
    function TWideStringField.GetDataSize: Integer;
    begin
      Result :=
        (Size + 1) * 2;
    end;
    
    
    { ---------------------------------------------------------------------
        TNumericField
      ---------------------------------------------------------------------}
    
    
    constructor TNumericField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      AlignMent:=taRightJustify;
    end;
    
    class procedure TNumericField.CheckTypeSize(AValue: Longint);
    begin
      // This procedure is only added because some TDataset descendents have the
      // but that they set the Size property as if it is the DataSize property.
      // To avoid problems with those descendents, allow values <= 16.
      If (AValue>16) Then
        DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
    end;
    
    procedure TNumericField.RangeError(AValue, Min, Max: Double);
    
    begin
      DatabaseErrorFMT(SRangeError,[AValue,Min,Max,FieldName]);
    end;
    
    procedure TNumericField.SetDisplayFormat(const AValue: string);
    
    begin
     If FDisplayFormat<>AValue then
       begin
       FDisplayFormat:=AValue;
       PropertyChanged(True);
       end;
    end;
    
    procedure TNumericField.SetEditFormat(const AValue: string);
    
    begin
      If FEditFormat<>AValue then
        begin
        FEditFormat:=AValue;
        PropertyChanged(True);
        end;
    end;
    
    function TNumericField.GetAsBoolean: Boolean;
    begin
      Result:=GetAsInteger<>0;
    end;
    
    procedure TNumericField.SetAsBoolean(AValue: Boolean);
    begin
      SetAsInteger(ord(AValue));
    end;
    
    { ---------------------------------------------------------------------
        TLongintField
      ---------------------------------------------------------------------}
    
    
    constructor TLongintField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDatatype(ftinteger);
      FMinRange:=Low(LongInt);
      FMaxRange:=High(LongInt);
      FValidchars:=['+','-','0'..'9'];
    end;
    
    function TLongintField.GetAsFloat: Double;
    
    begin
      Result:=GetAsInteger;
    end;
    
    function TLongintField.GetAsLargeint: Largeint;
    begin
      Result:=GetAsInteger;
    end;
    
    function TLongintField.GetAsInteger: Longint;
    
    begin
      If Not GetValue(Result) then
        Result:=0;
    end;
    
    function TLongintField.GetAsVariant: Variant;
    
    Var L : Longint;
    
    begin
      If GetValue(L) then
        Result:=L
      else
        Result:=Null;
    end;
    
    function TLongintField.GetAsString: string;
    
    Var L : Longint;
    
    begin
      If GetValue(L) then
        Result:=IntTostr(L)
      else
        Result:='';
    end;
    
    function TLongintField.GetDataSize: Integer;
    
    begin
      Result:=SizeOf(Longint);
    end;
    
    procedure TLongintField.GetText(var AText: string; ADisplayText: Boolean);
    
    var l : longint;
        fmt : string;
    
    begin
      Atext:='';
      If Not GetValue(l) then exit;
      If ADisplayText or (FEditFormat='') then
        fmt:=FDisplayFormat
      else
        fmt:=FEditFormat;
      If length(fmt)<>0 then
        AText:=FormatFloat(fmt,L)
      else
        Str(L,AText);
    end;
    
    function TLongintField.GetValue(var AValue: Longint): Boolean;
    
    Var L : Longint;
        P : PLongint;
    
    begin
      P:=@L;
      Result:=GetData(P);
      If Result then
        Case Datatype of
          ftInteger,ftAutoinc  : AValue:=Plongint(P)^;
          ftWord               : AValue:=Pword(P)^;
          ftSmallint           : AValue:=PSmallint(P)^;
        end;
    end;
    
    procedure TLongintField.SetAsLargeint(AValue: Largeint);
    begin
      if (AValue>=FMinRange) and (AValue<=FMaxRange) then
        SetAsInteger(AValue)
      else
        RangeError(AValue,FMinRange,FMaxRange);
    end;
    
    procedure TLongintField.SetAsFloat(AValue: Double);
    
    begin
      SetAsInteger(Round(AValue));
    end;
    
    procedure TLongintField.SetAsInteger(AValue: Longint);
    
    begin
      If CheckRange(AValue) then
        SetData(@AValue)
      else
        RangeError(AValue,FMinRange,FMaxRange);
    end;
    
    procedure TLongintField.SetVarValue(const AValue: Variant);
    begin
      SetAsInteger(AValue);
    end;
    
    procedure TLongintField.SetAsString(const AValue: string);
    
    Var L,Code : longint;
    
    begin
      If length(AValue)=0 then
        Clear
      else
        begin
        Val(AValue,L,Code);
        If Code=0 then
          SetAsInteger(L)
        else
          DatabaseErrorFMT(SNotAnInteger,[AValue]);
        end;
    end;
    
    Function TLongintField.CheckRange(AValue : longint) : Boolean;
    
    begin
      result := true;
      if (FMaxValue=0) then
        begin
        if (AValue>FMaxRange) Then result := false;
        end
      else
        if AValue>FMaxValue then result := false;
    
      if (FMinValue=0) then
        begin
        if (AValue<FMinRange) Then result := false;
        end
      else
        if AValue<FMinValue then result := false;
    end;
    
    Procedure TLongintField.SetMaxValue (AValue : longint);
    
    begin
      If (AValue>=FMinRange) and (AValue<=FMaxRange) then
        FMaxValue:=AValue
      else
        RangeError(AValue,FMinRange,FMaxRange);
    end;
    
    Procedure TLongintField.SetMinValue (AValue : longint);
    
    begin
      If (AValue>=FMinRange) and (AValue<=FMaxRange) then
        FMinValue:=AValue
      else
        RangeError(AValue,FMinRange,FMaxRange);
    end;
    
    { ---------------------------------------------------------------------
        TLargeintField
      ---------------------------------------------------------------------}
    
    
    constructor TLargeintField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDatatype(ftLargeint);
      FMinRange:=Low(Largeint);
      FMaxRange:=High(Largeint);
      FValidchars:=['+','-','0'..'9'];
    end;
    
    function TLargeintField.GetAsFloat: Double;
    
    begin
      Result:=GetAsLargeint;
    end;
    
    function TLargeintField.GetAsLargeint: Largeint;
    
    begin
      If Not GetValue(Result) then
        Result:=0;
    end;
    
    function TLargeIntField.GetAsVariant: Variant;
    
    Var L : Largeint;
    
    begin
      If GetValue(L) then
        Result:=L
      else
        Result:=Null;
    end;
    
    function TLargeintField.GetAsInteger: Longint;
    
    begin
      Result:=GetAsLargeint;
    end;
    
    function TLargeintField.GetAsString: string;
    
    Var L : Largeint;
    
    begin
      If GetValue(L) then
        Result:=IntTostr(L)
      else
        Result:='';
    end;
    
    function TLargeintField.GetDataSize: Integer;
    
    begin
      Result:=SizeOf(Largeint);
    end;
    
    procedure TLargeintField.GetText(var AText: string; ADisplayText: Boolean);
    
    var l : largeint;
        fmt : string;
    
    begin
      Atext:='';
      If Not GetValue(l) then exit;
      If ADisplayText or (FEditFormat='') then
        fmt:=FDisplayFormat
      else
        fmt:=FEditFormat;
      If length(fmt)<>0 then
        AText:=FormatFloat(fmt,L)
      else
        Str(L,AText);
    end;
    
    function TLargeintField.GetValue(var AValue: Largeint): Boolean;
    
    type
      PLargeint = ^Largeint;
    
    Var P : PLargeint;
    
    begin
      P:=@AValue;
      Result:=GetData(P);
    end;
    
    procedure TLargeintField.SetAsFloat(AValue: Double);
    
    begin
      SetAsLargeint(Round(AValue));
    end;
    
    procedure TLargeintField.SetAsLargeint(AValue: Largeint);
    
    begin
      If CheckRange(AValue) then
        SetData(@AValue)
      else
        RangeError(AValue,FMinRange,FMaxRange);
    end;
    
    procedure TLargeintField.SetAsInteger(AValue: Longint);
    
    begin
      SetAsLargeint(AValue);
    end;
    
    procedure TLargeintField.SetAsString(const AValue: string);
    
    Var L     : largeint;
        code  : longint;
    
    begin
      If length(AValue)=0 then
        Clear
      else
        begin
        Val(AValue,L,Code);
        If Code=0 then
          SetAsLargeint(L)
        else
          DatabaseErrorFMT(SNotAnInteger,[AValue]);
        end;
    end;
    
    procedure TLargeintField.SetVarValue(const AValue: Variant);
    begin
      SetAsLargeint(AValue);
    end;
    
    Function TLargeintField.CheckRange(AValue : largeint) : Boolean;
    
    begin
      result := true;
      if (FMaxValue=0) then
        begin
        if (AValue>FMaxRange) Then result := false;
        end
      else
        if AValue>FMaxValue then result := false;
    
      if (FMinValue=0) then
        begin
        if (AValue<FMinRange) Then result := false;
        end
      else
        if AValue<FMinValue then result := false;
    end;
    
    Procedure TLargeintField.SetMaxValue (AValue : largeint);
    
    begin
      If (AValue>=FMinRange) and (AValue<=FMaxRange) then
        FMaxValue:=AValue
      else
        RangeError(AValue,FMinRange,FMaxRange);
    end;
    
    Procedure TLargeintField.SetMinValue (AValue : largeint);
    
    begin
      If (AValue>=FMinRange) and (AValue<=FMaxRange) then
        FMinValue:=AValue
      else
        RangeError(AValue,FMinRange,FMaxRange);
    end;
    
    { TSmallintField }
    
    function TSmallintField.GetDataSize: Integer;
    
    begin
      Result:=SizeOf(SmallInt);
    end;
    
    constructor TSmallintField.Create(AOwner: TComponent);
    
    begin
      inherited Create(AOwner);
      SetDataType(ftSmallInt);
      FMinRange:=-32768;
      FMaxRange:=32767;
    end;
    
    
    { TWordField }
    
    function TWordField.GetDataSize: Integer;
    
    begin
      Result:=SizeOf(Word);
    end;
    
    constructor TWordField.Create(AOwner: TComponent);
    
    begin
      inherited Create(AOwner);
      SetDataType(ftWord);
      FMinRange:=0;
      FMaxRange:=65535;
      FValidchars:=['+','0'..'9'];
    end;
    
    { TAutoIncField }
    
    constructor TAutoIncField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOWner);
      SetDataType(ftAutoInc);
    end;
    
    Procedure TAutoIncField.SetAsInteger(AValue: Longint);
    
    begin
      // Some databases allows insertion of explicit values into identity columns
      // (some of them also allows (some not) updating identity columns)
      // So allow it at client side and leave check for server side
      //if not(FDataSet.State in [dsFilter,dsSetKey,dsInsert]) then
      //  DataBaseError(SCantSetAutoIncFields);
      inherited;
    end;
    
    { TFloatField }
    
    procedure TFloatField.SetCurrency(const AValue: Boolean);
    begin
      if FCurrency=AValue then exit;
      FCurrency:=AValue;
    end;
    
    procedure TFloatField.SetPrecision(const AValue: Longint);
    begin
      if (AValue = -1) or (AValue > 1) then
        FPrecision := AValue
      else
        FPrecision := 2;
    end;
    
    function TFloatField.GetAsFloat: Double;
    
    begin
      If Not GetData(@Result) Then
        Result:=0.0;
    end;
    
    function TFloatField.GetAsVariant: Variant;
    
    Var f : Double;
    
    begin
      If GetData(@f) then
        Result := f
      else
        Result:=Null;
    end;
    
    function TFloatField.GetAsLargeInt: LargeInt;
    begin
      Result:=Round(GetAsFloat);
    end;
    
    function TFloatField.GetAsInteger: Longint;
    
    begin
      Result:=Round(GetAsFloat);
    end;
    
    function TFloatField.GetAsString: string;
    
    Var R : Double;
    
    begin
      If GetData(@R) then
        Result:=FloatToStr(R)
      else
        Result:='';
    end;
    
    function TFloatField.GetDataSize: Integer;
    
    begin
      Result:=SizeOf(Double);
    end;
    
    procedure TFloatField.GetText(var TheText: string; ADisplayText: Boolean);
    
    Var
        fmt : string;
        E : Double;
        Digits : integer;
        ff: TFloatFormat;
    
    begin
      TheText:='';
      If Not GetData(@E) then exit;
      If ADisplayText or (Length(FEditFormat) = 0) Then
        Fmt:=FDisplayFormat
      else
        Fmt:=FEditFormat;
        
      Digits := 0;
      if not FCurrency then
        ff := ffGeneral
      else
        begin
        Digits := CurrencyDecimals;
        if ADisplayText then
          ff := ffCurrency
        else
          ff := ffFixed;
        end;
    
    
      If fmt<>'' then
        TheText:=FormatFloat(fmt,E)
      else
        TheText:=FloatToStrF(E,ff,FPrecision,Digits);
    end;
    
    procedure TFloatField.SetAsFloat(AValue: Double);
    
    begin
      If CheckRange(AValue) then
        SetData(@AValue)
      else
        RangeError(AValue,FMinValue,FMaxValue);
    end;
    
    procedure TFloatField.SetAsLargeInt(AValue: LargeInt);
    begin
      SetAsFloat(AValue);
    end;
    
    procedure TFloatField.SetAsInteger(AValue: Longint);
    
    begin
      SetAsFloat(AValue);
    end;
    
    procedure TFloatField.SetAsString(const AValue: string);
    
    Var R : Double;
    
    begin
      If (AValue='') then
        Clear
      else  
        try
          R := StrToFloat(AValue);
          SetAsFloat(R);
        except
          DatabaseErrorFmt(SNotAFloat, [AValue]);
        end;
    end;
    
    procedure TFloatField.SetVarValue(const AValue: Variant);
    begin
      SetAsFloat(AValue);
    end;
    
    constructor TFloatField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDatatype(ftfloat);
      FPrecision:=15;
      FValidChars := [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
    end;
    
    Function TFloatField.CheckRange(AValue : Double) : Boolean;
    
    begin
      If (FMinValue<>0) or (FMaxValue<>0) then
        Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
      else
        Result:=True;
    end;
    
    { TCurrencyField }
    
    Constructor TCurrencyField.Create(AOwner: TComponent);
    
    begin
      inherited Create(AOwner);
      SetDataType(ftCurrency);
      Currency := True;
    end;
    
    { TBooleanField }
    
    function TBooleanField.GetAsBoolean: Boolean;
    
    var b : wordbool;
    
    begin
      If GetData(@b) then
        Result := b
      else
        Result:=False;
    end;
    
    function TBooleanField.GetAsVariant: Variant;
    
    Var b : wordbool;
    
    begin
      If GetData(@b) then
        Result := b
      else
        Result:=Null;
    end;
    
    function TBooleanField.GetAsString: string;
    
    Var B : wordbool;
    
    begin
      If GetData(@B) then
        Result:=FDisplays[False,B]
      else
        result:='';
    end;
    
    function TBooleanField.GetDataSize: Integer;
    
    begin
      Result:=SizeOf(wordBool);
    end;
    
    function TBooleanField.GetDefaultWidth: Longint;
    
    begin
      Result:=Length(FDisplays[false,false]);
      If Result<Length(FDisplays[false,True]) then
        Result:=Length(FDisplays[false,True]);
    end;
    
    function TBooleanField.GetAsInteger: Longint;
    begin
      Result := ord(GetAsBoolean);
    end;
    
    procedure TBooleanField.SetAsInteger(AValue: Longint);
    begin
      SetAsBoolean(AValue<>0);
    end;
    
    procedure TBooleanField.SetAsBoolean(AValue: Boolean);
    
    var b : wordbool;
    
    begin
      b := AValue;
      SetData(@b);
    end;
    
    procedure TBooleanField.SetAsString(const AValue: string);
    
    Var Temp : string;
    
    begin
      Temp:=UpperCase(AValue);
      if Temp='' then
        Clear
      else if pos(Temp, FDisplays[True,True])=1 then
        SetAsBoolean(True)
      else if pos(Temp, FDisplays[True,False])=1 then
        SetAsBoolean(False)
      else
        DatabaseErrorFmt(SNotABoolean,[AValue]);
    end;
    
    procedure TBooleanField.SetVarValue(const AValue: Variant);
    begin
      SetAsBoolean(AValue);
    end;
    
    constructor TBooleanField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDataType(ftBoolean);
      DisplayValues:='True;False';
    end;
    
    Procedure TBooleanField.SetDisplayValues(const AValue : String);
    
    Var I : longint;
    
    begin
      If FDisplayValues<>AValue then
        begin
        I:=Pos(';',AValue);
        If (I<2) or (I=Length(AValue)) then
          DatabaseErrorFmt(SInvalidDisplayValues,[AValue]);
        FdisplayValues:=AValue;
        // Store display values and their uppercase equivalents;
        FDisplays[False,True]:=Copy(AValue,1,I-1);
        FDisplays[True,True]:=UpperCase(FDisplays[False,True]);
        FDisplays[False,False]:=Copy(AValue,I+1,Length(AValue)-i);
        FDisplays[True,False]:=UpperCase(FDisplays[False,False]);
        PropertyChanged(True);
        end;
    end;
    
    { TDateTimeField }
    
    procedure TDateTimeField.SetDisplayFormat(const AValue: string);
    begin
      if FDisplayFormat<>AValue then begin
        FDisplayFormat:=AValue;
        PropertyChanged(True);
      end;
    end;
    
    function TDateTimeField.GetAsDateTime: TDateTime;
    
    begin
      If Not GetData(@Result,False) then
        Result:=0;
    end;
    
    procedure TDateTimeField.SetVarValue(const AValue: Variant);
    begin
      SetAsDateTime(AValue);
    end;
    
    function TDateTimeField.GetAsVariant: Variant;
    
    Var d : tDateTime;
    
    begin
      If GetData(@d,False) then
        Result := d
      else
        Result:=Null;
    end;
    
    function TDateTimeField.GetAsFloat: Double;
    
    begin
      Result:=GetAsdateTime;
    end;
    
    
    function TDateTimeField.GetAsString: string;
    
    begin
      GetText(Result,False);
    end;
    
    
    function TDateTimeField.GetDataSize: Integer;
    
    begin
      Result:=SizeOf(TDateTime);
    end;
    
    
    procedure TDateTimeField.GetText(var TheText: string; ADisplayText: Boolean);
    
    Var R : TDateTime;
        F : String;
    
    begin
      If Not GetData(@R,False) then
        TheText:=''
      else
        begin
        If (ADisplayText) and (Length(FDisplayFormat)<>0) then
          F:=FDisplayFormat
        else
          Case DataType of
           ftTime : F:=LongTimeFormat;
           ftDate : F:=ShortDateFormat;
          else
           F:='c'
          end;
        TheText:=FormatDateTime(F,R);
        end;
    end;
    
    
    procedure TDateTimeField.SetAsDateTime(AValue: TDateTime);
    
    begin
      SetData(@AValue,False);
    end;
    
    
    procedure TDateTimeField.SetAsFloat(AValue: Double);
    
    begin
      SetAsDateTime(AValue);
    end;
    
    
    procedure TDateTimeField.SetAsString(const AValue: string);
    
    Var R : TDateTime;
    
    begin
      if AValue<>'' then
        begin
        R:=StrToDateTime(AValue);
        SetData(@R,False);
        end
      else
        SetData(Nil);
    end;
    
    
    constructor TDateTimeField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDataType(ftDateTime);
    end;
    
    
    { TDateField }
    
    constructor TDateField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDataType(ftDate);
    end;
    
    
    { TTimeField }
    
    constructor TTimeField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDataType(ftTime);
    end;
    
    procedure TTimeField.SetAsString(const AValue: string);
    Var R : TDateTime;
    begin
      if AValue='' then
        Clear    // set to NULL
      else
        begin
        R:=StrToTime(AValue);
        SetData(@R,False);
        end;
    end;
    
    
    
    { TBinaryField }
    
    class procedure TBinaryField.CheckTypeSize(AValue: Longint);
    
    begin
      // Just check for really invalid stuff; actual size is
      // dependent on the record...
      If AValue<1 then
        DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
    end;
    
    function TBinaryField.GetAsBytes: TBytes;
    begin
      if not GetValue(Result) then
        SetLength(Result, 0);
    end;
    
    
    function TBinaryField.GetAsString: string;
    var B: TBytes;
    begin
      if not GetValue(B) then
        Result := ''
      else
        SetString(Result, @B[0], length(B) div SizeOf(Char));
    end;
    
    
    function TBinaryField.GetAsVariant: Variant;
    var B: TBytes;
        P: Pointer;
    begin
      if not GetValue(B) then
        Result := Null
      else
      begin
        Result := VarArrayCreate([0, length(B)-1], varByte);
        P := VarArrayLock(Result);
        try
          Move(B[0], P^, length(B));
        finally
          VarArrayUnlock(Result);
        end;
      end;
    end;
    
    
    procedure TBinaryField.GetText(var TheText: string; ADisplayText: Boolean);
    
    begin
      TheText:=GetAsString;
    end;
    
    
    function TBinaryField.GetValue(var AValue: TBytes): Boolean;
    var B: TBytes;
    begin
      SetLength(B, DataSize);
      Result := assigned(B) and GetData(Pointer(B), True);
      if Result then
        if DataType = ftVarBytes then
          begin
          SetLength(AValue, PWord(B)^);
          Move(B[sizeof(Word)], AValue[0], Length(AValue));
          end
        else // ftBytes
          AValue := B;
    end;
    
    
    procedure TBinaryField.SetAsBytes(const AValue: TBytes);
    var Buf: array[0..dsMaxStringSize] of byte;
        DynBuf: TBytes;
        Len: Word;
        P: PByte;
    begin
      Len := Length(AValue);
      if Len >= DataSize then
        P := @AValue[0]
      else begin
        if DataSize <= dsMaxStringSize then
          P := @Buf[0]
        else begin
          SetLength(DynBuf, DataSize);
          P := @DynBuf[0];
        end;
    
        if DataType = ftVarBytes then begin
          PWord(P)^ := Len;
          Move(AValue[0], P[sizeof(Word)], Len);
        end
        else begin // ftBytes
          Move(AValue[0], P^, Len);
          FillChar(P[Len], DataSize-Len, 0); // right pad with #0
        end;
      end;
      SetData(P, True)
    end;
    
    
    procedure TBinaryField.SetAsString(const AValue: string);
    var B : TBytes;
    begin
      If Length(AValue) = DataSize then
        SetData(PChar(AValue))
      else
      begin
        SetLength(B, Length(AValue) * SizeOf(Char));
        Move(AValue[1], B[0], Length(B));
        SetAsBytes(B);
      end;
    end;
    
    
    procedure TBinaryField.SetText(const AValue: string);
    
    begin
      SetAsString(AValue);
    end;
    
    procedure TBinaryField.SetVarValue(const AValue: Variant);
    var P: Pointer;
        B: TBytes;
        Len: integer;
    begin
      if VarIsArray(AValue) then
      begin
        P := VarArrayLock(AValue);
        try
          Len := VarArrayHighBound(AValue, 1) + 1;
          SetLength(B, Len);
          Move(P^, B[0], Len);
        finally
          VarArrayUnlock(AValue);
        end;
        SetAsBytes(B);
      end
      else
        SetAsString(AValue);
    end;
    
    
    constructor TBinaryField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
    end;
    
    
    
    { TBytesField }
    
    function TBytesField.GetDataSize: Integer;
    
    begin
      Result:=Size;
    end;
    
    
    constructor TBytesField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDataType(ftBytes);
      Size:=16;
    end;
    
    
    
    { TVarBytesField }
    
    function TVarBytesField.GetDataSize: Integer;
    
    begin
      Result:=Size+2;
    end;
    
    
    constructor TVarBytesField.Create(AOwner: TComponent);
    
    begin
      INherited Create(AOwner);
      SetDataType(ftvarbytes);
      Size:=16;
    end;
    
    { TBCDField }
    
    class procedure TBCDField.CheckTypeSize(AValue: Longint);
    
    begin
      If not (AValue in [0..4]) then
        DatabaseErrorfmt(SInvalidFieldSize,[AValue]);
    end;
    
    function TBCDField.GetAsBCD: TBCD;
    Var
      c:system.Currency;
    
    begin
      If GetData(@c) then
        Result:=CurrToBCD(c)
      else
        Result:=NullBCD;
    end;
    
    function TBCDField.GetAsCurrency: Currency;
    
    begin
      if not GetData(@Result) then
        result := 0;
    end;
    
    function TBCDField.GetAsVariant: Variant;
    
    Var c : system.Currency;
    
    begin
      If GetData(@c) then
        Result := c
      else
        Result:=Null;
    end;
    
    function TBCDField.GetAsFloat: Double;
    
    begin
      result := GetAsCurrency;
    end;
    
    
    function TBCDField.GetAsInteger: Longint;
    
    begin
      result := round(GetAsCurrency);
    end;
    
    
    function TBCDField.GetAsString: string;
    
    var c : system.currency;
    
    begin
      If GetData(@C) then
        Result:=CurrToStr(C)
      else
        Result:='';
    end;
    
    function TBCDField.GetValue(var AValue: Currency): Boolean;
    
    begin
      Result := GetData(@AValue);
    end;
    
    function TBCDField.GetDataSize: Integer;
    
    begin
      result := sizeof(system.currency);
    end;
    
    function TBCDField.GetDefaultWidth: Longint;
    
    begin
      if precision > 0 then result := precision
        else result := 10;
    end;
    
    procedure TBCDField.GetText(var TheText: string; ADisplayText: Boolean);
    var
      c : system.currency;
      fmt: String;
    begin
      if GetData(@C) then begin
        if aDisplayText or (FEditFormat='') then
          fmt := FDisplayFormat
        else
          fmt := FEditFormat;
        if fmt<>'' then
          TheText := FormatFloat(fmt,C)
        else if fCurrency then begin
          if aDisplayText then
            TheText := FloatToStrF(C, ffCurrency, FPrecision, 2{digits?})
          else
            TheText := FloatToStrF(C, ffFixed, FPrecision, 2{digits?});
        end else
          TheText := FloatToStrF(C, ffGeneral, FPrecision, 0{digits?});
      end else
        TheText := '';
    end;
    
    procedure TBCDField.SetAsBCD(const AValue: TBCD);
    var
      c:system.currency;
    begin
      if BCDToCurr(AValue,c) then
        SetAsCurrency(c);
    end;
    
    procedure TBCDField.SetAsCurrency(AValue: Currency);
    
    begin
      If CheckRange(AValue) then
        setdata(@AValue)
      else
        RangeError(AValue,FMinValue,FMaxValue);
    end;
    
    procedure TBCDField.SetVarValue(const AValue: Variant);
    begin
      SetAsCurrency(AValue);
    end;
    
    Function TBCDField.CheckRange(AValue : Currency) : Boolean;
    
    begin
      If (FMinValue<>0) or (FMaxValue<>0) then
        Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
      else
        Result:=True;
    end;
    
    procedure TBCDField.SetAsFloat(AValue: Double);
    
    begin
      SetAsCurrency(AValue);
    end;
    
    
    procedure TBCDField.SetAsInteger(AValue: Longint);
    
    begin
      SetAsCurrency(AValue);
    end;
    
    
    procedure TBCDField.SetAsString(const AValue: string);
    
    begin
      if AValue='' then
        Clear    // set to NULL
      else
        SetAsCurrency(strtocurr(AValue));
    end;
    
    constructor TBCDField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      FMaxValue := 0;
      FMinValue := 0;
      FValidChars := [DecimalSeparator, '+', '-', '0'..'9'];
      SetDataType(ftBCD);
      FPrecision := 15;
      Size:=4;
    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 := VarFMTBcdCreate(bcd)
      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.GetAsLargeInt: LargeInt;
    var bcd: TBCD;
    begin
      if GetData(@bcd) then
        Result := BCDToInteger(bcd)
      else
        Result := 0;
    end;
    
    function TFMTBCDField.GetAsInteger: 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;
      fmt: String;
    begin
      if GetData(@bcd) then begin
        if aDisplayText or (FEditFormat='') then
          fmt := FDisplayFormat
        else
          fmt := FEditFormat;
        if fmt<>'' then
          TheText := FormatBCD(fmt,bcd)
        else if fCurrency then begin
          if aDisplayText then
            TheText := BcdToStrF(bcd, ffCurrency, FPrecision, 2)
          else
            TheText := BcdToStrF(bcd, ffFixed, FPrecision, 2);
        end else
          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);
    begin
      SetAsBCD(VarToBCD(AValue));
    end;
    
    procedure TFMTBCDField.SetAsFloat(AValue: Double);
    begin
      SetAsBCD(DoubleToBCD(AValue));
    end;
    
    procedure TFMTBCDField.SetAsLargeInt(AValue: LargeInt);
    begin
      SetAsBCD(IntegerToBCD(AValue));
    end;
    
    procedure TFMTBCDField.SetAsInteger(AValue: Longint);
    begin
      SetAsBCD(IntegerToBCD(AValue));
    end;
    
    procedure TFMTBCDField.SetAsString(const AValue: string);
    begin
      if AValue='' then
        Clear    // set to NULL
      else
        SetAsBCD(StrToBCD(AValue));
    end;
    
    
    { TBlobField }
    
    function TBlobField.GetBlobStream(Mode: TBlobStreamMode): TStream;
    
    begin
      Result:=FDataset.CreateBlobStream(Self,Mode);
    end;
    
    procedure TBlobField.FreeBuffers;
    
    begin
    end;
    
    function TBlobField.GetAsBytes: TBytes;
    var
      Stream : TStream;
      Len    : Integer;
    begin
      Stream := GetBlobStream(bmRead);
      if Stream <> nil then
        try
          Len := Stream.Size;
          SetLength(Result, Len);
          if Len > 0 then
            Stream.ReadBuffer(Result[0], Len);
        finally
          Stream.Free;
        end
      else
        SetLength(Result, 0);
    end;
    
    function TBlobField.GetAsString: string;
    var
      Stream : TStream;
      Len    : Integer;
    begin
      Stream := GetBlobStream(bmRead);
      if Stream <> nil then
        with Stream do
          try
            Len := Size;
            SetLength(Result, Len);
            if Len > 0 then
              ReadBuffer(Result[1], Len);
          finally
            Free
          end
      else
        Result := '';
    end;
    
    function TBlobField.GetAsWideString: WideString;
    var
      Stream : TStream;
      Len    : Integer;
    begin
      Stream := GetBlobStream(bmRead);
      if Stream <> nil then
        with Stream do
          try
            Len := Size;
            SetLength(Result, (Len+1) div 2);
            if Len > 0 then
              ReadBuffer(Result[1] ,Len);
          finally
            Free
          end
      else
        Result := '';
    end;
    
    function TBlobField.GetAsVariant: Variant;
    
    Var s : string;
    
    begin
      if not GetIsNull then
        begin
        s := GetAsString;
        result := s;
        end
      else
        result := Null;
    end;
    
    
    function TBlobField.GetBlobSize: Longint;
    var
      Stream: TStream;
    begin
      Stream := GetBlobStream(bmRead);
      if Stream <> nil then
        with Stream do
          try
            Result:=Size;
          finally
            Free;
          end
      else
        Result := 0;
    end;
    
    
    function TBlobField.GetIsNull: Boolean;
    
    begin
      if Not Modified then
        Result:= inherited GetIsNull
      else
        with GetBlobStream(bmRead) do
          try
            Result:=(Size=0);
          finally
            Free;
          end;
    end;
    
    
    procedure TBlobField.GetText(var TheText: string; ADisplayText: Boolean);
    
    begin
      TheText:=inherited GetAsString;
    end;
    
    procedure TBlobField.SetAsBytes(const AValue: TBytes);
    var
      Len : Integer;
    begin
      with GetBlobStream(bmWrite) do
        try
          Len := Length(AValue);
          if Len > 0 then
            WriteBuffer(AValue[0], Len);
        finally
          Free;
        end;
    end;
    
    
    procedure TBlobField.SetAsString(const AValue: string);
    var
      Len : Integer;
    begin
      with GetBlobStream(bmWrite) do
        try
          Len := Length(AValue);
          if Len > 0 then
            WriteBuffer(AValue[1], Len);
        finally
          Free;
        end;
    end;
    
    
    procedure TBlobField.SetAsWideString(const AValue: WideString);
    var
      Len : Integer;
    begin
      with GetBlobStream(bmWrite) do
        try
          Len := Length(AValue) * 2;
          if Len > 0 then
            WriteBuffer(AValue[1], Len);
        finally
          Free;
        end;
    end;
    
    
    procedure TBlobField.SetText(const AValue: string);
    
    begin
      SetAsString(AValue);
    end;
    
    procedure TBlobField.SetVarValue(const AValue: Variant);
    begin
      SetAsString(AValue);
    end;
    
    
    constructor TBlobField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOWner);
      SetDataType(ftBlob);
    end;
    
    
    procedure TBlobField.Clear;
    
    begin
      GetBlobStream(bmWrite).free;
    end;
    
    
    class function TBlobField.IsBlob: Boolean;
    
    begin
      Result:=True;
    end;
    
    
    procedure TBlobField.LoadFromFile(const FileName: string);
    
    Var S : TFileStream;
    
    begin
      S:=TFileStream.Create(FileName,fmOpenRead);
      try
        LoadFromStream(S);
      finally
        S.Free;
      end;
    end;
    
    
    procedure TBlobField.LoadFromStream(Stream: TStream);
    
    begin
      with GetBlobStream(bmWrite) do
        try
          CopyFrom(Stream,0);
        finally
          Free;
        end;
    end;
    
    
    procedure TBlobField.SaveToFile(const FileName: string);
    
    Var S : TFileStream;
    
    begin
      S:=TFileStream.Create(FileName,fmCreate);
      try
        SaveToStream(S);
      finally
        S.Free;
      end;
    end;
    
    
    procedure TBlobField.SaveToStream(Stream: TStream);
    
    Var S : TStream;
    
    begin
      S:=GetBlobStream(bmRead);
      Try
        If Assigned(S) then
          Stream.CopyFrom(S,0);
      finally
        S.Free;
      end;
    end;
    
    procedure TBlobField.SetFieldType(AValue: TFieldType);
    
    begin
      If AValue in [Low(TBlobType)..High(TBlobType)] then
        SetDatatype(AValue);
    end;
    
    { TMemoField }
    
    constructor TMemoField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDataType(ftMemo);
    end;
    
    function TMemoField.GetAsWideString: WideString;
    begin
      Result := GetAsString;
    end;
    
    procedure TMemoField.SetAsWideString(const AValue: WideString);
    begin
      SetAsString(AValue);
    end;
    
    { TWideMemoField }
    
    constructor TWideMemoField.Create(AOwner: TComponent);
    begin
      inherited Create(AOwner);
      SetDataType(ftWideMemo);
    end;
    
    function TWideMemoField.GetAsString: string;
    begin
      Result := GetAsWideString;
    end;
    
    procedure TWideMemoField.SetAsString(const AValue: string);
    begin
      SetAsWideString(AValue);
    end;
    
    function TWideMemoField.GetAsVariant: Variant;
    
    Var s : string;
    
    begin
      if not GetIsNull then
        begin
        s := GetAsWideString;
        result := s;
        end
      else result := Null;
    end;
    
    procedure TWideMemoField.SetVarValue(const AValue: Variant);
    begin
      SetAsWideString(AValue);
    end;
    
    { TGraphicField }
    
    constructor TGraphicField.Create(AOwner: TComponent);
    
    begin
      Inherited Create(AOwner);
      SetDataType(ftGraphic);
    end;
    
    { TGuidField }
    
    constructor TGuidField.Create(AOwner: TComponent);
    begin
      Size := 38;
      inherited Create(AOwner);
      SetDataType(ftGuid);
    end;
    
    class procedure TGuidField.CheckTypeSize(AValue: LongInt);
    begin
      if AValue <> 38 then
        DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
    end;
    
    function TGuidField.GetAsGuid: TGUID;
    const
      nullguid: TGUID = '{00000000-0000-0000-0000-000000000000}';
    var
      S: string;
    begin
      S := GetAsString;
      if S = '' then
        Result := nullguid
      else
        Result := StringToGuid(S);
    end;
    
    function TGuidField.GetDefaultWidth: LongInt;
    begin
      Result := 38;
    end;
    
    procedure TGuidField.SetAsGuid(const AValue: TGUID);
    begin
      SetAsString(GuidToString(AValue));
    end;
    
    function TVariantField.GetDefaultWidth: Integer;
    begin
      Result := 15;
    end;
    
    { TVariantField }
    
    constructor TVariantField.Create(AOwner: TComponent);
    begin
      inherited Create(AOwner);
      SetDataType(ftVariant);
    end;
    
    class procedure TVariantField.CheckTypeSize(aValue: Integer);
    begin
      { empty }
    end;
    
    function TVariantField.GetAsBoolean: Boolean;
    begin
      Result := GetAsVariant;
    end;
    
    function TVariantField.GetAsDateTime: TDateTime;
    begin
      Result := GetAsVariant;
    end;
    
    function TVariantField.GetAsFloat: Double;
    begin
      Result := GetAsVariant;
    end;
    
    function TVariantField.GetAsInteger: Longint;
    begin
      Result := GetAsVariant;
    end;
    
    function TVariantField.GetAsString: string;
    begin
      Result := VarToStr(GetAsVariant);
    end;
    
    function TVariantField.GetAsWideString: WideString;
    begin
      Result := VarToWideStr(GetAsVariant);
    end;
    
    function TVariantField.GetAsVariant: Variant;
    begin
      if not GetData(@Result) then
        Result := Null;
    end;
    
    procedure TVariantField.SetAsBoolean(aValue: Boolean);
    begin
      SetVarValue(aValue);
    end;
    
    procedure TVariantField.SetAsDateTime(aValue: TDateTime);
    begin
      SetVarValue(aValue);
    end;
    
    procedure TVariantField.SetAsFloat(aValue: Double);
    begin
      SetVarValue(aValue);
    end;
    
    procedure TVariantField.SetAsInteger(AValue: Longint);
    begin
      SetVarValue(aValue);
    end;
    
    procedure TVariantField.SetAsString(const aValue: string);
    begin
      SetVarValue(aValue);
    end;
    
    procedure TVariantField.SetAsWideString(const aValue: WideString);
    begin
      SetVarValue(aValue);
    end;
    
    procedure TVariantField.SetVarValue(const aValue: Variant);
    begin
      SetData(@aValue);
    end;
    
    { TFieldsEnumerator }
    
    function TFieldsEnumerator.GetCurrent: TField;
    begin
      Result := FFields[FPosition];
    end;
    
    constructor TFieldsEnumerator.Create(AFields: TFields);
    begin
      inherited Create;
      FFields := AFields;
      FPosition := -1;
    end;
    
    function TFieldsEnumerator.MoveNext: Boolean;
    begin
      inc(FPosition);
      Result := FPosition < FFields.Count;
    end;
    
    { TFields }
    
    Constructor TFields.Create(ADataset : TDataset);
    
    begin
      FDataSet:=ADataset;
      FFieldList:=TFpList.Create;
      FValidFieldKinds:=[fkData..fkInternalcalc];
    end;
    
    Destructor TFields.Destroy;
    
    begin
      if Assigned(FFieldList) then
        Clear;
      FreeAndNil(FFieldList);
      inherited Destroy;
    end;
    
    Procedure Tfields.Changed;
    
    begin
      if (FDataSet <> nil) and not (csDestroying in FDataSet.ComponentState) and FDataset.Active then
        FDataSet.DataEvent(deFieldListChange, 0);
      If Assigned(FOnChange) then
        FOnChange(Self);
    end;
    
    Procedure TFields.CheckfieldKind(Fieldkind : TFieldKind; Field : TField);
    
    begin
      If Not (FieldKind in ValidFieldKinds) Then
        DatabaseErrorFmt(SInvalidFieldKind,[Field.FieldName]);
    end;
    
    Function Tfields.GetCount : Longint;
    
    begin
      Result:=FFieldList.Count;
    end;
    
    
    Function TFields.GetField (Index : longint) : TField;
    
    begin
      Result:=Tfield(FFieldList[Index]);
    end;
    
    procedure Tfields.SetField(Index: Integer; Value: TField);
    begin
      Fields[Index].Assign(Value);
    end;
    
    Procedure TFields.SetFieldIndex (Field : TField;Value : Integer);
    
    Var Old : Longint;
    
    begin
      Old := FFieldList.indexOf(Field);
      If Old=-1 then
        Exit;
      // Check value
      If Value<0 Then Value:=0;
      If Value>=Count then Value:=Count-1;
      If Value<>Old then
        begin
        FFieldList.Delete(Old);
        FFieldList.Insert(Value,Field);
        Field.PropertyChanged(True);
        Changed;
        end;
    end;
    
    Procedure TFields.Add(Field : TField);
    
    begin
      CheckFieldName(Field.FieldName);
      FFieldList.Add(Field);
      Field.FFields:=Self;
      Changed;
    end;
    
    Procedure TFields.CheckFieldName (Const Value : String);
    
    begin
      If FindField(Value)<>Nil then
        DataBaseErrorFmt(SDuplicateFieldName,[Value],FDataset);
    end;
    
    Procedure TFields.CheckFieldNames (Const Value : String);
    
    
    Var I : longint;
        S,T : String;
    begin
      T:=Value;
      Repeat
        I:=Pos(';',T);
        If I=0 Then I:=Length(T)+1;
        S:=Copy(T,1,I-1);
        Delete(T,1,I);
        // Will raise an error if no such field...
        FieldByName(S);
      Until (T='');
    end;
    
    Procedure TFields.Clear;
    var
      AField: TField;
    begin
      while FFieldList.Count > 0 do 
        begin
        AField := TField(FFieldList.Last);
        AField.FDataSet := Nil;
        AField.Free;
        FFieldList.Delete(FFieldList.Count - 1);
        end;
      Changed;
    end;
    
    Function TFields.FindField (Const Value : String) : TField;
    
    Var S : String;
        I : longint;
    
    begin
      Result:=Nil;
      S:=UpperCase(Value);
      For I:=0 To FFieldList.Count-1 do
        If S=UpperCase(TField(FFieldList[i]).FieldName) Then
          Begin
          {$ifdef dsdebug}
          Writeln ('Found field ',Value);
          {$endif}
          Result:=TField(FFieldList[I]);
          Exit;
          end;
    end;
    
    Function TFields.FieldByName (Const Value : String) : TField;
    
    begin
      Result:=FindField(Value);
      If result=Nil then
        DatabaseErrorFmt(SFieldNotFound,[Value],FDataset);
    end;
    
    Function TFields.FieldByNumber(FieldNo : Integer) : TField;
    
    Var i : Longint;
    
    begin
      Result:=Nil;
      For I:=0 to FFieldList.Count-1 do
        If FieldNo=TField(FFieldList[I]).FieldNo then
          begin
          Result:=TField(FFieldList[i]);
          Exit;
          end;
    end;
    
    Function TFields.GetEnumerator: TFieldsEnumerator;
    
    begin
      Result:=TFieldsEnumerator.Create(Self);
    end;
    
    Procedure TFields.GetFieldNames (Values : TStrings);
    
    Var i : longint;
    
    begin
      Values.Clear;
      For I:=0 to FFieldList.Count-1 do
        Values.Add(Tfield(FFieldList[I]).FieldName);
    end;
    
    Function TFields.IndexOf(Field : TField) : Longint;
    
    begin
      Result:=FFieldList.IndexOf(Field);
    end;
    
    procedure TFields.Remove(Value : TField);
    
    begin
      FFieldList.Remove(Value);
      Value.FFields := nil;
      Changed;
    end;
    
    
    fields.inc (68,067 bytes)
  • firebird_fpc2.6.4.txt (14,622 bytes)
     N:265 E:4 F:0 I:15
      TTestBasics N:7 E:0 F:0 I:0
        TestParseSQL
        TestInitFielddefsFromFields
        TestDoubleFieldDef
        TestFieldDefWithoutDS
        TestGetParamList
        TestGetFieldList
        TestExtractFieldName
      TTestFieldTypes N:75 E:3 F:0 I:7
        TestEmptyUpdateQuery
        TestParseJoins
        TestParseUnion
        TestDoubleFieldNames
        TestNumericNames
        TestApplyUpdFieldnames
        TestStringLargerThen8192
        TestInsertLargeStrFields  Error: EAccessViolation
          Exception:   Access violation
          Source unit: 
          Method name: 
          Line number: 0
        TestLargeRecordSize  Error: EAccessViolation
          Exception:   Access violation
          Source unit: 
          Method name: 
          Line number: 0
        TestClearUpdateableStatus  Ignored test: This test does only apply to MySQL because the used SQL-statement is MySQL only.
        TestReadOnlyParseSQL
        TestpfInUpdateFlag
        TestAggregates
        TestServerFilter
        Test11Params
        TestRowsAffected
        TestLocateNull
        TestLocateOnMoreRecords
        TestStringsReplace
        TestCircularParams
        TestBug9744
        TestCrossStringDateParam  Error: EVariantError
          Exception:   Invalid variant type cast
          Source unit: 
          Method name: 
          Line number: 0
        TestSetBlobAsMemoParam
        TestSetBlobAsBlobParam
        TestSetBlobAsStringParam
        TestNonNullableParams
        TestDblQuoteEscComments
        TestInsertReturningQuery
        TestOpenStoredProc
        TestTemporaryTable
        TestRefresh
        TestQueryAfterReconnect
        TestParametersAndDates  Ignored test: This test does not apply to this sqldb-connection type, since it doesn't use semicolons for casts
        TestExceptOnsecClose
        TestErrorOnEmptyStatement
        TestBlob
        TestChangeBlob
        TestBlobGetText
        TestBlobSize
        TestInt
        TestTinyint
        TestNumeric
        TestFloat
        TestDate
        TestDateTime
        TestString
        TestUnlVarChar  Ignored test: This test does only apply to Postgres, since others don't support varchars without length given
        TestNullValues
        TestParamQuery
        TestStringParamQuery
        TestFixedStringParamQuery
        TestDateParamQuery
        TestSmallIntParamQuery
        TestIntParamQuery
        TestLargeIntParamQuery
        TestTimeParamQuery
        TestDateTimeParamQuery
        TestFmtBCDParamQuery
        TestFloatParamQuery
        TestBCDParamQuery
        TestBytesParamQuery  Ignored test: Fields of the type Bytes are not supported by this sqldb-connection type
        TestVarBytesParamQuery  Ignored test: Fields of the type VarBytes are not supported by this sqldb-connection type
        TestBooleanParamQuery  Ignored test: Fields of the type Boolean are not supported by this sqldb-connection type
        TestTableNames
        TestGetTables
        TestFieldNames
        TestGetFieldNames
        TestUpdateIndexDefs
        TestMultipleFieldPKIndexDefs
        TestGetIndexDefs
        TestSQLClob
        TestSQLLargeint
        TestSQLInterval
        TestSQLIdentity  Ignored test: This test does not apply to this sqldb-connection type
        TestSQLReal
      TTestDBBasics N:33 E:0 F:0 I:3
        TestSetFieldValues
        TestGetFieldValues
        TestSupportIntegerFields
        TestSupportSmallIntFields
        TestSupportWordFields  Ignored test: Fields of the type Word are not supported by this type of dataset
        TestSupportStringFields
        TestSupportBooleanFields  Ignored test: Fields of the type Boolean are not supported by this type of dataset
        TestSupportFloatFields
        TestSupportLargeIntFields
        TestSupportDateFields
        TestSupportTimeFields
        TestSupportCurrencyFields  Ignored test: Fields of the type Currency are not supported by this type of dataset
        TestSupportBCDFields
        TestSupportfmtBCDFields
        TestSupportFixedStringFields
        TestSupportBlobFields
        TestSupportMemoFields
        TestDoubleClose
        TestCalculatedField
        TestAssignFieldftString
        TestAssignFieldftFixedChar
        TestSelectQueryBasics
        TestPostOnlyInEditState
        TestMove
        TestActiveBufferWhenClosed
        TestEOFBOFClosedDataset
        TestLayoutChangedEvents
        TestDataEventsResync
        TestRecordcountAfterReopen
        TestdeFieldListChange
        TestExceptionLocateClosed
        TestCanModifySpecialFields
        TestDetectionNonMatchingDataset
      TTestCursorDBBasics N:28 E:0 F:0 I:0
        TestCancelUpdDelete1
        TestCancelUpdDelete2
        TestAppendInsertRecord
        TestBookmarks
        TestBookmarkValid
        TestDelete1
        TestDelete2
        TestLocate
        TestLocateCaseIns
        TestLocateCaseInsInts
        TestLookup
        TestFirst
        TestIntFilter
        TestOnFilter
        TestStringFilter
        TestNullAtOpen
        TestAppendOnEmptyDataset
        TestInsertOnEmptyDataset
        TestEofAfterFirst
        TestLastAppendCancel
        TestRecNo
        TestSetRecNo
        TestBug7007
        TestBug6893
        TestRequired
        TestOldValueObsolete
        TestOldValue
        TestModified
      TTestBufDatasetDBBasics N:31 E:0 F:0 I:2
        TestClosedIndexFieldNames
        TestFileNameProperty
        TestClientDatasetAsMemDataset
        TestSaveAsXML
        TestIsEmpty
        TestBufDatasetCancelUpd
        TestBufDatasetCancelUpd1
        TestMultipleDeleteUpdateBuffer
        TestDoubleDelete
        TestReadOnly
        TestMergeChangeLog
        TestAddIndexInteger
        TestAddIndexSmallInt
        TestAddIndexBoolean  Ignored test: Fields of the type Boolean are not supported by this type of dataset
        TestAddIndexFloat
        TestAddIndexLargeInt
        TestAddIndexDateTime
        TestAddIndexCurrency  Ignored test: Fields of the type Currency are not supported by this type of dataset
        TestAddIndexBCD
        TestAddIndex
        TestAddDescIndex
        TestAddCaseInsIndex
        TestInactSwitchIndex
        TestAddIndexActiveDS
        TestAddIndexEditDS
        TestIndexFieldNames
        TestIndexFieldNamesAct
        TestIndexCurRecord
        TestAddDblIndex
        TestIndexEditRecord
        TestIndexAppendRecord
      TTestUniDirectionalDBBasics N:33 E:0 F:0 I:3
        TestSetFieldValues
        TestGetFieldValues
        TestSupportIntegerFields
        TestSupportSmallIntFields
        TestSupportWordFields  Ignored test: Fields of the type Word are not supported by this type of dataset
        TestSupportStringFields
        TestSupportBooleanFields  Ignored test: Fields of the type Boolean are not supported by this type of dataset
        TestSupportFloatFields
        TestSupportLargeIntFields
        TestSupportDateFields
        TestSupportTimeFields
        TestSupportCurrencyFields  Ignored test: Fields of the type Currency are not supported by this type of dataset
        TestSupportBCDFields
        TestSupportfmtBCDFields
        TestSupportFixedStringFields
        TestSupportBlobFields
        TestSupportMemoFields
        TestDoubleClose
        TestCalculatedField
        TestAssignFieldftString
        TestAssignFieldftFixedChar
        TestSelectQueryBasics
        TestPostOnlyInEditState
        TestMove
        TestActiveBufferWhenClosed
        TestEOFBOFClosedDataset
        TestLayoutChangedEvents
        TestDataEventsResync
        TestRecordcountAfterReopen
        TestdeFieldListChange
        TestExceptionLocateClosed
        TestCanModifySpecialFields
        TestDetectionNonMatchingDataset
      TTestBufDatasetStreams N:34 E:1 F:0 I:0
        TestSimpleEditCancelUpd
        TestSimpleDeleteCancelUpd
        TestMoreDeletesCancelUpd
        TestSimpleInsertCancelUpd
        MoreInsertsCancelUpd
        SeveralEditsCancelUpd
        DeleteAllCancelUpd
        DeleteAllInsertCancelUpd
        AppendDeleteCancelUpd
        TestSimpleEditApplUpd
        TestSimpleDeleteApplUpd
        TestMoreDeletesApplUpd
        TestSimpleInsertApplUpd
        MoreInsertsApplUpd
        SeveralEditsApplUpd
        DeleteAllApplUpd
        DeleteAllInsertApplUpd
        NullInsertUpdateApplUpd
        TestBasicsXML
        TestSimpleEditXML
        TestSimpleDeleteXML
        TestMoreDeletesXML
        TestSimpleInsertXML
        TestMoreInsertsXML
        TestSeveralEditsXML
        TestDeleteAllXML
        TestDeleteAllInsertXML
        TestStreamingBlobFieldsXML
        TestStreamingBigBlobFieldsXML  Error: EAccessViolation
          Exception:   Access violation
          Source unit: 
          Method name: 
          Line number: 0
        TestStreamingCalculatedFieldsXML
        TestAppendDeleteBIN
        TestFileNameProperty
        TestXmlFileRecognition
        TestCloseDatasetNoConnection
      TTestTSQLQuery N:2 E:0 F:0 I:0
        TestMasterDetail
        TestUpdateServerIndexDefs
      TTestTSQLConnection N:1 E:0 F:0 I:0
        ReplaceMe
      TTestTSQLScript N:1 E:0 F:0 I:0
        TestExecuteScript
      TTestDBExport N:20 E:0 F:0 I:0
        TestDBFExport_DBaseIV
        TestDBFExport_DBaseVII
        TestDBFExport_FoxPro
        TestCSVExport
        TestCSVExport_RFC4180WithHeader
        TestCSVExport_TweakSettingsSemicolon
        TestFixedTextExport
        TestJSONExport
        TestRTFExport
        TestSQLExport
        TestTeXExport
        TestXMLExport
        TestXSDExport_Access_NoXSD_DecimalOverride
        TestXSDExport_Access_NoXSD_NoDecimalOverride
        TestXSDExport_Access_XSD_DecimalOverride
        TestXSDExport_Access_XSD_NoDecimalOverride
        TestXSDExport_ADONET_NoXSD
        TestXSDExport_ADONET_XSD
        TestXSDExport_DelphiClientDataset
        TestXSDExport_Excel
    
    Number of run tests: 265
    Number of errors:    4
    Number of failures:  0
    
    List of errors:
      Error: 
        Message:           TTestFieldTypes.TestInsertLargeStrFields: Access violation
        Exception class:   EAccessViolation
        Exception message: Access violation
        Source unitname:   
        Line number:       0
        Failed methodname: 
    
      Error: 
        Message:           TTestFieldTypes.TestLargeRecordSize: Access violation
        Exception class:   EAccessViolation
        Exception message: Access violation
        Source unitname:   
        Line number:       0
        Failed methodname: 
    
      Error: 
        Message:           TTestFieldTypes.TestCrossStringDateParam: Invalid variant type cast
        Exception class:   EVariantError
        Exception message: Invalid variant type cast
        Source unitname:   
        Line number:       0
        Failed methodname: 
    
      Error: 
        Message:           TTestBufDatasetStreams.TestStreamingBigBlobFieldsXML: Access violation
        Exception class:   EAccessViolation
        Exception message: Access violation
        Source unitname:   
        Line number:       0
        Failed methodname: 
    
    
    List of ignored tests:
      Ignored test: 
        Message:           TTestFieldTypes.TestClearUpdateableStatus: This test does only apply to MySQL because the used SQL-statement is MySQL only.
        Exception class:   EIgnoredTest
        Exception message: This test does only apply to MySQL because the used SQL-statement is MySQL only.
      Ignored test: 
        Message:           TTestFieldTypes.TestParametersAndDates: This test does not apply to this sqldb-connection type, since it doesn't use semicolons for casts
        Exception class:   EIgnoredTest
        Exception message: This test does not apply to this sqldb-connection type, since it doesn't use semicolons for casts
      Ignored test: 
        Message:           TTestFieldTypes.TestUnlVarChar: This test does only apply to Postgres, since others don't support varchars without length given
        Exception class:   EIgnoredTest
        Exception message: This test does only apply to Postgres, since others don't support varchars without length given
      Ignored test: 
        Message:           TTestFieldTypes.TestBytesParamQuery: Fields of the type Bytes are not supported by this sqldb-connection type
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Bytes are not supported by this sqldb-connection type
      Ignored test: 
        Message:           TTestFieldTypes.TestVarBytesParamQuery: Fields of the type VarBytes are not supported by this sqldb-connection type
        Exception class:   EIgnoredTest
        Exception message: Fields of the type VarBytes are not supported by this sqldb-connection type
      Ignored test: 
        Message:           TTestFieldTypes.TestBooleanParamQuery: Fields of the type Boolean are not supported by this sqldb-connection type
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Boolean are not supported by this sqldb-connection type
      Ignored test: 
        Message:           TTestFieldTypes.TestSQLIdentity: This test does not apply to this sqldb-connection type
        Exception class:   EIgnoredTest
        Exception message: This test does not apply to this sqldb-connection type
      Ignored test: 
        Message:           TTestDBBasics.TestSupportWordFields: Fields of the type Word are not supported by this type of dataset
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Word are not supported by this type of dataset
      Ignored test: 
        Message:           TTestDBBasics.TestSupportBooleanFields: Fields of the type Boolean are not supported by this type of dataset
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Boolean are not supported by this type of dataset
      Ignored test: 
        Message:           TTestDBBasics.TestSupportCurrencyFields: Fields of the type Currency are not supported by this type of dataset
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Currency are not supported by this type of dataset
      Ignored test: 
        Message:           TTestBufDatasetDBBasics.TestAddIndexBoolean: Fields of the type Boolean are not supported by this type of dataset
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Boolean are not supported by this type of dataset
      Ignored test: 
        Message:           TTestBufDatasetDBBasics.TestAddIndexCurrency: Fields of the type Currency are not supported by this type of dataset
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Currency are not supported by this type of dataset
      Ignored test: 
        Message:           TTestUniDirectionalDBBasics.TestSupportWordFields: Fields of the type Word are not supported by this type of dataset
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Word are not supported by this type of dataset
      Ignored test: 
        Message:           TTestUniDirectionalDBBasics.TestSupportBooleanFields: Fields of the type Boolean are not supported by this type of dataset
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Boolean are not supported by this type of dataset
      Ignored test: 
        Message:           TTestUniDirectionalDBBasics.TestSupportCurrencyFields: Fields of the type Currency are not supported by this type of dataset
        Exception class:   EIgnoredTest
        Exception message: Fields of the type Currency are not supported by this type of dataset
    
    
    
    
    firebird_fpc2.6.4.txt (14,622 bytes)

Relationships

related to 0026113 resolvedReinier Olislagers FPC TSQLQuery & TPQConnection (PostgreSQL), only INSERT first character of any string length (VARCHAR type) 
related to 0028673 resolvedMichl Packages VARCHAR field truncates 

Activities

Branislav

2014-04-24 20:18

reporter  

FirebirdTest.zip (174,632 bytes)

Luiz Americo

2014-04-24 23:29

developer   ~0074576

I found similar issue with Postgres in 2.6.4. I tested in 2.7.1/trunk and was fixed. As a workaround i defined smaller VARCHAR field (200). Not sure if is valid to firebird also.

Branislav

2014-04-25 04:58

reporter   ~0074578

Last edited: 2014-04-28 13:52

View 2 revisions

If VARCHAR field size is smaller (200, 100 ....), the first problem is not present on Firebird.

Reinier Olislagers

2014-05-01 16:16

developer   ~0074727

Last edited: 2014-05-01 16:40

View 2 revisions

Info thanks to Lacak: probably caused by bug fixed by Lacak in FPC trunk r27691 (which was probably overlooked while testing 2.6.4). The bug manifests itself in failure of dbtestframework test TTestFieldTypes.TestInsertLargeStrFields
 - see e.g.
http://svn.freepascal.org/cgi-bin/viewvc.cgi/tags/release_2_6_4/packages/fcl-db/tests/testfieldtypes.pas?revision=26871&view=markup
or packages/fcl-db/tests/testfieldtypes.pas in your fpc directory

Backporting the one line fix in r27691
http://svn.freepascal.org/cgi-bin/viewvc.cgi/trunk/packages/fcl-db/src/base/fields.inc?r1=27691&r2=27690&pathrev=27691
to FPC fixes 2.6 solves that issue.

Tested this with the example program in this bug using Lazarus fixes 1.2 and it does indeed solve the first issue presented by Branislav.

LacaK

2014-05-05 12:40

developer   ~0074777

Summary:
1. should be fixed in rev. 27691, 27717
2. should be fixed in rev. 27738 (as a workaround you can use in your sample TSQLTransaction1.Action:=caCommit instead of Action:=caCommitRetaining)

Thanks for reporting thid bug!

Reinier Olislagers

2014-05-06 08:32

developer  

fields.inc (68,067 bytes)
{
    This file is part of the Free Pascal run time library.
    Copyright (c) 1999-2000 by Michael Van Canneyt, member of the
    Free Pascal development team

    TFields and related components implementations.
Note: this file includes partial fixes for bug http://bugs.freepascal.org/view.php?id=26068
    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}
{Procedure DumpMem (P : Pointer;Size : Longint);

Var i : longint;

begin
  Write ('Memory dump : ');
  For I:=0 to Size-1 do
    Write (Pbyte(P)[i],' ');
  Writeln;
end;}

{ ---------------------------------------------------------------------
    TFieldDef
  ---------------------------------------------------------------------}

Constructor TFieldDef.Create(ACollection : TCollection);

begin
  Inherited create(ACollection);
  FFieldNo:=Index+1;
end;

Constructor TFieldDef.Create(AOwner: TFieldDefs; const AName: string;
      ADataType: TFieldType; ASize: Integer; ARequired: Boolean; AFieldNo: Longint);

begin
{$ifdef dsdebug }
  Writeln('TFieldDef.Create : ',Aname,'(',AFieldNo,')');
{$endif}
  Inherited Create(AOwner);
  Name:=Aname;
  FDatatype:=ADatatype;
  FSize:=ASize;
  FRequired:=ARequired;
  FPrecision:=-1;
  FFieldNo:=AFieldNo;
end;

Destructor TFieldDef.Destroy;

begin
  Inherited destroy;
end;

procedure TFieldDef.Assign(APersistent: TPersistent);
var fd: TFieldDef;
begin
  fd := nil;
  if APersistent is TFieldDef then
    fd := APersistent as TFieldDef;
  if Assigned(fd) then begin
    Collection.BeginUpdate;
    try
      Name := fd.Name;
      DataType := fd.DataType;
      Size := fd.Size;
      Precision := fd.Precision;
      FRequired := fd.Required;
    finally
      Collection.EndUpdate;
    end;
  end else
  inherited Assign(APersistent);
end;

Function TFieldDef.CreateField(AOwner: TComponent): TField;

Var TheField : TFieldClass;

begin
{$ifdef dsdebug}
  Writeln ('Creating field '+FNAME);
{$endif dsdebug}
  TheField:=GetFieldClass;
  if TheField=Nil then
    DatabaseErrorFmt(SUnknownFieldType,[FName]);
  Result:=Thefield.Create(AOwner);
  Try
    Result.Size:=FSize;
    Result.Required:=FRequired;
    Result.FFieldName:=FName;
    Result.FDisplayLabel:=DisplayName;
    Result.FFieldNo:=Self.FieldNo;
    Result.SetFieldType(DataType);
    Result.FReadOnly:= (faReadOnly in Attributes);
{$ifdef dsdebug}
    Writeln ('TFieldDef.CReateField : Trying to set dataset');
{$endif dsdebug}
{$ifdef dsdebug}
    Writeln ('TFieldDef.CReateField : Result Fieldno : ',Result.FieldNo,' Self : ',FieldNo);
{$endif dsdebug}
    Result.Dataset:=TFieldDefs(Collection).Dataset;
    If (Result is TFloatField) then
      TFloatField(Result).Precision:=FPrecision;
    if (Result is TBCDField) then
      TBCDField(Result).Precision:=FPrecision;
    if (Result is TFmtBCDField) then
      TFmtBCDField(Result).Precision:=FPrecision;
  except
    Result.Free;
    Raise;
  end;

end;

procedure TFieldDef.SetAttributes(AValue: TFieldAttributes);
begin
  FAttributes := AValue;
  Changed(False);
end;

procedure TFieldDef.SetDataType(AValue: TFieldType);
begin
  FDataType := AValue;
  Changed(False);
end;

procedure TFieldDef.SetPrecision(const AValue: Longint);
begin
  FPrecision := AValue;
  Changed(False);
end;

procedure TFieldDef.SetSize(const AValue: Integer);
begin
  FSize := AValue;
  Changed(False);
end;

procedure TFieldDef.SetRequired(const AValue: Boolean);
begin
  FRequired := AValue;
  Changed(False);
end;

Function TFieldDef.GetFieldClass : TFieldClass;

begin
  //!! Should be owner as tdataset but that doesn't work ??

  If Assigned(Collection) And
     (Collection is TFieldDefs) And
     Assigned(TFieldDefs(Collection).Dataset) then
    Result:=TFieldDefs(Collection).Dataset.GetFieldClass(FDataType)
  else
    Result:=Nil;
end;

{ ---------------------------------------------------------------------
    TFieldDefs
  ---------------------------------------------------------------------}

{
destructor TFieldDefs.Destroy;

begin
  FItems.Free;
  // This will destroy all fielddefs since we own them...
  Inherited Destroy;
end;
}

procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType);

begin
  Add(AName,ADatatype,0,False);
end;

procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize : Word);

begin
  Add(AName,ADatatype,ASize,False);
end;

procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word;
  ARequired: Boolean);

begin
  If Length(AName)=0 Then
    DatabaseError(SNeedFieldName);
  // the fielddef will register itself here as a owned component.
  // fieldno is 1 based !
  BeginUpdate;
  try
    TFieldDef.Create(Self,AName,ADataType,ASize,Arequired,Count+1);
  finally
    EndUpdate;
  end;
end;

function TFieldDefs.GetItem(Index: Longint): TFieldDef;

begin
  Result := TFieldDef(inherited Items[Index]);
end;

procedure TFieldDefs.SetItem(Index: Longint; const AValue: TFieldDef);
begin
  inherited Items[Index] := AValue;
end;

constructor TFieldDefs.Create(ADataset: TDataset);
begin
  Inherited Create(ADataset, Owner, TFieldDef);
end;

procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);

Var I : longint;

begin
  Clear;
  For i:=0 to FieldDefs.Count-1 do
    With FieldDefs[i] do
      Add(Name,DataType,Size,Required);
end;

function TFieldDefs.Find(const AName: string): TFieldDef;
begin
  Result := (Inherited Find(AName)) as TFieldDef;
  if Result=nil then DatabaseErrorFmt(SFieldNotFound,[AName],FDataset);
end;

{
procedure TFieldDefs.Clear;

Var I : longint;

begin
  For I:=FItems.Count-1 downto 0 do
    TFieldDef(Fitems[i]).Free;
  FItems.Clear;
end;
}

procedure TFieldDefs.Update;

begin
  if not Updated then
    begin
    If Assigned(Dataset) then
      DataSet.InitFieldDefs;
    Updated := True;
    end;
end;

function TFieldDefs.MakeNameUnique(const AName: String): string;
var DblFieldCount : integer;
begin
  DblFieldCount := 0;
  Result := AName;
  while assigned(inherited Find(Result)) do
    begin
    inc(DblFieldCount);
    Result := AName + '_' + IntToStr(DblFieldCount);
    end;
end;

Function TFieldDefs.AddFieldDef : TFieldDef;

begin
  Result:=TFieldDef.Create(Self,'',ftUnknown,0,False,Count+1);
end;

{ ---------------------------------------------------------------------
    TField
  ---------------------------------------------------------------------}

Const
  SBCD = 'BCD';
  SBoolean = 'Boolean';
  SDateTime = 'TDateTime';
  SFloat = 'Float';
  SInteger = 'Integer';
  SLargeInt = 'LargeInt';
  SVariant = 'Variant';
  SString = 'String';
  SBytes = 'Bytes';

constructor TField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  FVisible:=True;
  FValidChars:=[#0..#255];

  FProviderFlags := [pfInUpdate,pfInWhere];
end;

destructor TField.Destroy;

begin
  IF Assigned(FDataSet) then
    begin
    FDataSet.Active:=False;
    if Assigned(FFields) then
      FFields.Remove(Self);
    end;
  FLookupList.Free;
  Inherited Destroy;
end;

function TField.AccessError(const TypeName: string): EDatabaseError;

begin
  Result:=EDatabaseError.CreateFmt(SinvalidTypeConversion,[TypeName,FFieldName]);
end;

procedure TField.Assign(Source: TPersistent);

begin
  if Source = nil then Clear
  else if Source is TField then begin
    Value := TField(Source).Value;
  end else
    inherited Assign(Source);
end;

procedure TField.AssignValue(const AValue: TVarRec);
  procedure Error;
  begin
    DatabaseErrorFmt(SFieldValueError, [DisplayName]);
  end;

begin
  with AValue do
    case VType of
      vtInteger:
        AsInteger := VInteger;
      vtBoolean:
        AsBoolean := VBoolean;
      vtChar:
        AsString := VChar;
      vtExtended:
        AsFloat := VExtended^;
      vtString:
        AsString := VString^;
      vtPointer:
        if VPointer <> nil then Error;
      vtPChar:
        AsString := VPChar;
      vtObject:
        if (VObject = nil) or (VObject is TPersistent) then
          Assign(TPersistent(VObject))
        else
          Error;
      vtAnsiString:
        AsString := string(VAnsiString);
      vtCurrency:
        AsCurrency := VCurrency^;
      vtVariant:
        if not VarIsClear(VVariant^) then Self.Value := VVariant^;
      vtWideString:
        AsWideString := WideString(VWideString);
      vtInt64:
        AsLargeInt := VInt64^;
    else
      Error;
    end;
end;

procedure TField.Change;

begin
  If Assigned(FOnChange) Then
    FOnChange(Self);
end;

procedure TField.CheckInactive;

begin
  If Assigned(FDataSet) then
    FDataset.CheckInactive;
end;

procedure TField.Clear;

begin
  if FieldKind in [fkData, fkInternalCalc] then
    SetData(Nil);
end;

procedure TField.DataChanged;

begin
  FDataset.DataEvent(deFieldChange,ptrint(Self));
end;

procedure TField.FocusControl;
var
  Field1: TField;
begin
  Field1 := Self;
  FDataSet.DataEvent(deFocusControl,ptrint(@Field1));
end;

procedure TField.FreeBuffers;

begin
  // Empty. Provided for backward compatibiliy;
  // TDataset manages the buffers.
end;

function TField.GetAsBCD: TBCD;
begin
  raise AccessError(SBCD);
end;

function TField.GetAsBoolean: Boolean;
begin
  raise AccessError(SBoolean);
end;

function TField.GetAsBytes: TBytes;
begin
  SetLength(Result, DataSize);
  if assigned(result) and not GetData(@Result[0], False) then
    Result := nil;
end;

function TField.GetAsDateTime: TDateTime;

begin
  raise AccessError(SdateTime);
end;

function TField.GetAsFloat: Double;

begin
  raise AccessError(SDateTime);
end;

function TField.GetAsLongint: Longint;

begin
  Result:=GetAsInteger;
end;

function TField.GetAsInteger: Longint;

begin
  raise AccessError(SInteger);
end;

function TField.GetAsVariant: Variant;

begin
  raise AccessError(SVariant);
end;


function TField.GetAsString: string;

begin
  Result := GetClassDesc;
end;

function TField.GetAsWideString: WideString;
begin
  Result := GetAsString;
end;

function TField.GetOldValue: Variant;

var SaveState : TDatasetState;

begin
  SaveState := FDataset.State;
  try
    FDataset.SetTempState(dsOldValue);
    Result := GetAsVariant;
  finally
    FDataset.RestoreState(SaveState);
  end;
end;

function TField.GetNewValue: Variant;

var SaveState : TDatasetState;

begin
  SaveState := FDataset.State;
  try
    FDataset.SetTempState(dsNewValue);
    Result := GetAsVariant;
  finally
    FDataset.RestoreState(SaveState);
  end;
end;

procedure TField.SetNewValue(const AValue: Variant);

var SaveState : TDatasetState;

begin
  SaveState := FDataset.State;
  try
    FDataset.SetTempState(dsNewValue);
    SetAsVariant(AValue);
  finally
    FDataset.RestoreState(SaveState);
  end;
end;

function TField.GetCurValue: Variant;

var SaveState : TDatasetState;

begin
  SaveState := FDataset.State;
  try
    FDataset.SetTempState(dsCurValue);
    Result := GetAsVariant;
  finally
    FDataset.RestoreState(SaveState);
  end;
end;

function TField.GetCanModify: Boolean;

begin
  Result:=Not ReadOnly;
  If Result then
    begin
    Result := FieldKind in [fkData, fkInternalCalc];
    if Result then
      begin
      Result:=Assigned(DataSet) and Dataset.Active;
      If Result then
        Result:= DataSet.CanModify;
      end;
    end;
end;

function TField.GetClassDesc: String;
var ClassN : string;
begin
  ClassN := copy(ClassName,2,pos('Field',ClassName)-2);
  if isNull then
    result := '(' + LowerCase(ClassN) + ')'
   else
    result := '(' + UpperCase(ClassN) + ')';
end;

function TField.GetData(Buffer: Pointer): Boolean;

begin
  Result:=GetData(Buffer,True);
end;

function TField.GetData(Buffer: Pointer; NativeFormat : Boolean): Boolean;

begin
  IF FDataset=Nil then
    DatabaseErrorFmt(SNoDataset,[FieldName]);
  If FVAlidating then
    begin
    result:=assigned(FValueBuffer);
    If Result and assigned(Buffer) then
      Move (FValueBuffer^,Buffer^ ,DataSize);
    end
  else
    Result:=FDataset.GetFieldData(Self,Buffer,NativeFormat);
end;

function TField.GetDataSize: Integer;

begin
  Result:=0;
end;

function TField.GetDefaultWidth: Longint;

begin
  Result:=10;
end;

function TField.GetDisplayName  : String;

begin
  If FDisplayLabel<>'' then
    result:=FDisplayLabel
  else
    Result:=FFieldName;
end;

Function TField.IsDisplayStored : Boolean;

begin
  Result:=(DisplayLabel<>FieldName);
end;

function TField.GetLookupList: TLookupList;
begin
  if not Assigned(FLookupList) then
    FLookupList := TLookupList.Create;
  Result := FLookupList;
end;

procedure TField.CalcLookupValue;
begin
  if FLookupCache then
    Value := LookupList.ValueOfKey(FDataSet.FieldValues[FKeyFields])
  else if Assigned(FLookupDataSet) and FDataSet.Active then
    Value := FLookupDataSet.Lookup(FLookupKeyfields, FDataSet.FieldValues[FKeyFields], FLookupresultField);
end;

function TField.getIndex : longint;

begin
  If Assigned(FDataset) then
    Result:=FDataset.FFieldList.IndexOf(Self)
  else
    Result:=-1;
end;

function TField.GetLookup: Boolean;
begin
  Result := FieldKind = fkLookup;
end;

function TField.GetAsLargeInt: LargeInt;
begin
  Raise AccessError(SLargeInt);
end;

function TField.GetAsCurrency: Currency;
begin
  Result := GetAsFloat;
end;

procedure TField.SetAlignment(const AValue: TAlignMent);
begin
  if FAlignment <> AValue then
    begin
    FAlignment := AValue;
    PropertyChanged(false);
    end;
end;

procedure TField.SetIndex(const AValue: Integer);
begin
  if FFields <> nil then FFields.SetFieldIndex(Self, AValue)
end;

procedure TField.SetAsCurrency(AValue: Currency);
begin
  SetAsFloat(AValue);
end;

function TField.GetIsNull: Boolean;

begin
  Result:=Not(GetData (Nil));
end;

function TField.GetParentComponent: TComponent;

begin
  Result := DataSet;
end;

procedure TField.GetText(var AText: string; ADisplayText: Boolean);

begin
  AText:=GetAsString;
end;

function TField.HasParent: Boolean;

begin
  HasParent:=True;
end;

function TField.IsValidChar(InputChar: Char): Boolean;

begin
  // FValidChars must be set in Create.
  Result:=InputChar in FValidChars;
end;

procedure TField.RefreshLookupList;
var
  tmpActive: Boolean;
begin
  if not Assigned(FLookupDataSet) or (Length(FLookupKeyfields) = 0)
  or (Length(FLookupresultField) = 0) or (Length(FKeyFields) = 0) then
    Exit;
    
  tmpActive := FLookupDataSet.Active;
  try
    FLookupDataSet.Active := True;
    FFields.CheckFieldNames(FKeyFields);
    FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
    FLookupDataset.FieldByName(FLookupResultField); // I presume that if it doesn't exist it throws exception, and that a field with null value is still valid
    LookupList.Clear; // have to be F-less because we might be creating it here with getter!

    FLookupDataSet.DisableControls;
    try
      FLookupDataSet.First;
      while not FLookupDataSet.Eof do
      begin
        FLookupList.Add(FLookupDataSet.FieldValues[FLookupKeyfields], FLookupDataSet.FieldValues[FLookupResultField]);
        FLookupDataSet.Next;
      end;
    finally
      FLookupDataSet.EnableControls;
    end;
  finally
    FLookupDataSet.Active := tmpActive;
  end;
end;

procedure TField.Notification(AComponent: TComponent; Operation: TOperation);

begin
  Inherited Notification(AComponent,Operation);
  if (Operation = opRemove) and (AComponent = FLookupDataSet) then
    FLookupDataSet := nil;
end;

procedure TField.PropertyChanged(LayoutAffected: Boolean);

begin
  If (FDataset<>Nil) and (FDataset.Active) then
    If LayoutAffected then
      FDataset.DataEvent(deLayoutChange,0)
    else
      FDataset.DataEvent(deDatasetchange,0);
end;

procedure TField.ReadState(Reader: TReader);

begin
  inherited ReadState(Reader);
  if Reader.Parent is TDataSet then
    DataSet := TDataSet(Reader.Parent);
end;

procedure TField.SetAsBCD(const AValue: TBCD);
begin
  Raise AccessError(SBCD);
end;

procedure TField.SetAsBytes(const AValue: TBytes);
begin
  raise AccessError(SBytes);
end;

procedure TField.SetAsBoolean(AValue: Boolean);

begin
  Raise AccessError(SBoolean);
end;

procedure TField.SetAsDateTime(AValue: TDateTime);

begin
  Raise AccessError(SDateTime);
end;

procedure TField.SetAsFloat(AValue: Double);

begin
  Raise AccessError(SFloat);
end;

procedure TField.SetAsVariant(const AValue: Variant);

begin
  if VarIsNull(AValue) then
    Clear
  else
    try
      SetVarValue(AValue);
    except
      on EVariantError do DatabaseErrorFmt(SFieldValueError, [DisplayName]);
    end;
end;


procedure TField.SetAsLongint(AValue: Longint);

begin
  SetAsInteger(AValue);
end;

procedure TField.SetAsInteger(AValue: Longint);

begin
  raise AccessError(SInteger);
end;

procedure TField.SetAsLargeint(AValue: Largeint);
begin
  Raise AccessError(SLargeInt);
end;

procedure TField.SetAsString(const AValue: string);

begin
  Raise AccessError(SString);
end;

procedure TField.SetAsWideString(const AValue: WideString);
begin
  SetAsString(AValue);
end;


procedure TField.SetData(Buffer: Pointer);

begin
 SetData(Buffer,True);
end;

procedure TField.SetData(Buffer: Pointer; NativeFormat : Boolean);

begin
  If Not Assigned(FDataset) then
    DatabaseErrorFmt(SNoDataset,[FieldName]);
  FDataSet.SetFieldData(Self,Buffer, NativeFormat);
end;

Procedure TField.SetDataset (AValue : TDataset);

begin
{$ifdef dsdebug}
  Writeln ('Setting dataset');
{$endif}
  If AValue=FDataset then exit;
  If Assigned(FDataset) Then
    begin
    FDataset.CheckInactive;
    FDataset.FFieldList.Remove(Self);
    end;
  If Assigned(AValue) then
    begin
    AValue.CheckInactive;
    AValue.FFieldList.Add(Self);
    end;
  FDataset:=AValue;
end;

procedure TField.SetDataType(AValue: TFieldType);

begin
  FDataType := AValue;
end;

procedure TField.SetFieldType(AValue: TFieldType);

begin
  { empty }
end;

procedure TField.SetParentComponent(AParent: TComponent);

begin
  if not (csLoading in ComponentState) then
    DataSet := AParent as TDataSet;
end;

procedure TField.SetSize(AValue: Integer);

begin
  CheckInactive;
  CheckTypeSize(AValue);
  FSize:=AValue;
end;

procedure TField.SetText(const AValue: string);

begin
  AsString:=AValue;
end;

procedure TField.SetVarValue(const AValue: Variant);
begin
  Raise AccessError(SVariant);
end;

procedure TField.Validate(Buffer: Pointer);

begin
  If assigned(OnValidate) Then
    begin
    FValueBuffer:=Buffer;
    FValidating:=True;
    Try
      OnValidate(Self);
    finally
      FValidating:=False;
    end;
    end;
end;

class function Tfield.IsBlob: Boolean;

begin
  Result:=False;
end;

class procedure TField.CheckTypeSize(AValue: Longint);

begin
  If (AValue<>0) and Not IsBlob Then
    DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
end;

// TField private methods

procedure TField.SetEditText(const AValue: string);
begin
  if Assigned(OnSetText) then
    OnSetText(Self, AValue)
  else
    SetText(AValue);
end;

function TField.GetEditText: String;
begin
  SetLength(Result, 0);
  if Assigned(OnGetText) then
    OnGetText(Self, Result, False)
  else
    GetText(Result, False);
end;

function TField.GetDisplayText: String;
begin
  SetLength(Result, 0);
  if Assigned(OnGetText) then
    OnGetText(Self, Result, True)
  else
    GetText(Result, True);
end;

procedure TField.SetDisplayLabel(const AValue: string);
begin
  if FDisplayLabel<>AValue then
    begin
    FDisplayLabel:=AValue;
    PropertyChanged(true);
    end;
end;

procedure TField.SetDisplayWidth(const AValue: Longint);
begin
  if FDisplayWidth<>AValue then
    begin
    FDisplayWidth:=AValue;
    PropertyChanged(True);
    end;
end;

function TField.GetDisplayWidth: integer;
begin
  if FDisplayWidth=0 then
    result:=GetDefaultWidth
  else
    result:=FDisplayWidth;
end;

procedure TField.SetLookup(const AValue: Boolean);
const
  ValueToLookupMap: array[Boolean] of TFieldKind = (fkData, fkLookup);
begin
  FieldKind := ValueToLookupMap[AValue];
end;

procedure TField.SetReadOnly(const AValue: Boolean);
begin
  if (FReadOnly<>AValue) then
    begin
    FReadOnly:=AValue;
    PropertyChanged(True);
    end;
end;

procedure TField.SetVisible(const AValue: Boolean);
begin
  if FVisible<>AValue then
    begin
    FVisible:=AValue;
    PropertyChanged(True);
    end;
end;


{ ---------------------------------------------------------------------
    TStringField
  ---------------------------------------------------------------------}


constructor TStringField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDataType(ftString);
  FFixedChar := False;
  FTransliterate := False;
  FSize:=20;
end;

procedure TStringField.SetFieldType(AValue: TFieldType);
begin
  if avalue in [ftString, ftFixedChar] then
    SetDataType(AValue);
end;

class procedure TStringField.CheckTypeSize(AValue: Longint);

begin
// A size of 0 is allowed, since for example Firebird allows
// a query like: 'select '' as fieldname from table' which
// results in a string with size 0.
  If (AValue<0) Then
    databaseErrorFmt(SInvalidFieldSize,[AValue])
end;

function TStringField.GetAsBoolean: Boolean;

Var S : String;

begin
  S:=GetAsString;
  result := (Length(S)>0) and (Upcase(S[1]) in ['T',YesNoChars[True]]);
end;

function TStringField.GetAsDateTime: TDateTime;

begin
  Result:=StrToDateTime(GetAsString);
end;

function TStringField.GetAsFloat: Double;

begin
  Result:=StrToFloat(GetAsString);
end;

function TStringField.GetAsInteger: Longint;

begin
  Result:=StrToInt(GetAsString);
end;

function TStringField.GetAsString: string;

begin
  If Not GetValue(Result) then
    Result:='';
end;

function TStringField.GetAsVariant: Variant;

Var s : string;

begin
  If GetValue(s) then
    Result:=s
  else
    Result:=Null;
end;


function TStringField.GetDataSize: Integer;

begin
  Result:=Size+1;
end;

function TStringField.GetDefaultWidth: Longint;

begin
  result:=Size;
end;

Procedure TStringField.GetText(var AText: string; ADisplayText: Boolean);

begin
    AText:=GetAsString;
end;

function TStringField.GetValue(var AValue: string): Boolean;

Var Buf, TBuf : TStringFieldBuffer;
    DynBuf, TDynBuf : Array of char;

begin
  if DataSize <= dsMaxStringSize then
    begin
    Result:=GetData(@Buf);
    Buf[Size]:=#0;  //limit string to Size
    If Result then
      begin
      if Transliterate then
        begin
        DataSet.Translate(Buf,TBuf,False);
        AValue:=TBuf;
        end
      else
        AValue:=Buf
      end
    end
  else
    begin
    SetLength(DynBuf,DataSize);
    Result:=GetData(@DynBuf[0]);
    DynBuf[Size]:=#0;  //limit string to Size
    If Result then
      begin
      if Transliterate then
        begin
        SetLength(TDynBuf,DataSize);
        DataSet.Translate(@DynBuf[0],@TDynBuf[0],False);
        AValue:=pchar(TDynBuf);
        end
      else
        AValue:=pchar(DynBuf);
      end
    end;
end;

procedure TStringField.SetAsBoolean(AValue: Boolean);

begin
  If AValue Then
    SetAsString('T')
  else
    SetAsString('F');
end;

procedure TStringField.SetAsDateTime(AValue: TDateTime);

begin
  SetAsString(DateTimeToStr(AValue));
end;

procedure TStringField.SetAsFloat(AValue: Double);

begin
  SetAsString(FloatToStr(AValue));
end;

procedure TStringField.SetAsInteger(AValue: Longint);

begin
  SetAsString(intToStr(AValue));
end;

procedure TStringField.SetAsString(const AValue: string);

var Buf      : TStringFieldBuffer;
    DynBuf   : array of char;

begin
  if Length(AValue)=0 then
    begin
    Buf := #0;
    SetData(@Buf);
    end
  else if DataSize <= dsMaxStringSize then
    begin
    if FTransliterate then
      DataSet.Translate(@AValue[1],Buf,True)
    else
      // The data is copied into the buffer, since some TDataset descendents copy
      // the whole buffer-length in SetData. (See bug 8477)
      StrPLCopy(PChar(Buf), AValue, Size); //Buf := AValue; backported FPC trunk revision 27717
    // If length(AValue) > DataSize the buffer isn't terminated properly
    Buf[DataSize-1] := #0;
    SetData(@Buf);
    end
  else
    begin
    SetLength(DynBuf, DataSize);
    if FTransliterate then
      DataSet.Translate(@AValue[1],@DynBuf[0],True)
    else
      StrPLCopy(PChar(DynBuf), AValue, Size); //StrPLCopy(@DynBuf[0], AValue, DataSize); Backported FPC trunk revision 27691,27717 
    SetData(@DynBuf[0]);
    end
end;

procedure TStringField.SetVarValue(const AValue: Variant);
begin
  SetAsString(AValue);
end;

{ ---------------------------------------------------------------------
    TWideStringField
  ---------------------------------------------------------------------}

class procedure TWideStringField.CheckTypeSize(AValue: Integer);
begin
// A size of 0 is allowed, since for example Firebird allows
// a query like: 'select '' as fieldname from table' which
// results in a string with size 0.
  If (AValue<0) Then
    databaseErrorFmt(SInvalidFieldSize,[AValue]);
end;

constructor TWideStringField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftWideString);
end;

procedure TWideStringField.SetFieldType(AValue: TFieldType);
begin
  if avalue in [ftWideString, ftFixedWideChar] then
    SetDataType(AValue);
end;

function TWideStringField.GetValue(var AValue: WideString): Boolean;
var
  FixBuffer : array[0..dsMaxStringSize div 2] of WideChar;
  DynBuffer : array of WideChar;
  Buffer    : PWideChar;
begin
  if DataSize <= dsMaxStringSize then begin
    Result := GetData(@FixBuffer, False);
    FixBuffer[Size]:=#0;     //limit string to Size
    AValue := FixBuffer;
  end else begin
    SetLength(DynBuffer, Succ(Size));
    Buffer := PWideChar(DynBuffer);
    Result := GetData(Buffer, False);
    Buffer[Size]:=#0;     //limit string to Size
    if Result then
      AValue := Buffer;
  end;
end;

function TWideStringField.GetAsString: string;
begin
  Result := GetAsWideString;
end;

procedure TWideStringField.SetAsString(const AValue: string);
begin
  SetAsWideString(AValue);
end;

function TWideStringField.GetAsVariant: Variant;
var
  ws: WideString;
begin
  if GetValue(ws) then
    Result := ws
  else
    Result := Null;
end;

procedure TWideStringField.SetVarValue(const AValue: Variant);
begin
  SetAsWideString(AValue);
end;

function TWideStringField.GetAsWideString: WideString;
begin
  if not GetValue(Result) then
    Result := '';
end;

procedure TWideStringField.SetAsWideString(const AValue: WideString);
const
  NullWideChar : WideChar = #0;
var
  Buffer : PWideChar;
begin
  if Length(AValue)>0 then
    Buffer := PWideChar(@AValue[1])
  else
    Buffer := @NullWideChar;
  SetData(Buffer, False);
end;

function TWideStringField.GetDataSize: Integer;
begin
  Result :=
    (Size + 1) * 2;
end;


{ ---------------------------------------------------------------------
    TNumericField
  ---------------------------------------------------------------------}


constructor TNumericField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  AlignMent:=taRightJustify;
end;

class procedure TNumericField.CheckTypeSize(AValue: Longint);
begin
  // This procedure is only added because some TDataset descendents have the
  // but that they set the Size property as if it is the DataSize property.
  // To avoid problems with those descendents, allow values <= 16.
  If (AValue>16) Then
    DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
end;

procedure TNumericField.RangeError(AValue, Min, Max: Double);

begin
  DatabaseErrorFMT(SRangeError,[AValue,Min,Max,FieldName]);
end;

procedure TNumericField.SetDisplayFormat(const AValue: string);

begin
 If FDisplayFormat<>AValue then
   begin
   FDisplayFormat:=AValue;
   PropertyChanged(True);
   end;
end;

procedure TNumericField.SetEditFormat(const AValue: string);

begin
  If FEditFormat<>AValue then
    begin
    FEditFormat:=AValue;
    PropertyChanged(True);
    end;
end;

function TNumericField.GetAsBoolean: Boolean;
begin
  Result:=GetAsInteger<>0;
end;

procedure TNumericField.SetAsBoolean(AValue: Boolean);
begin
  SetAsInteger(ord(AValue));
end;

{ ---------------------------------------------------------------------
    TLongintField
  ---------------------------------------------------------------------}


constructor TLongintField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDatatype(ftinteger);
  FMinRange:=Low(LongInt);
  FMaxRange:=High(LongInt);
  FValidchars:=['+','-','0'..'9'];
end;

function TLongintField.GetAsFloat: Double;

begin
  Result:=GetAsInteger;
end;

function TLongintField.GetAsLargeint: Largeint;
begin
  Result:=GetAsInteger;
end;

function TLongintField.GetAsInteger: Longint;

begin
  If Not GetValue(Result) then
    Result:=0;
end;

function TLongintField.GetAsVariant: Variant;

Var L : Longint;

begin
  If GetValue(L) then
    Result:=L
  else
    Result:=Null;
end;

function TLongintField.GetAsString: string;

Var L : Longint;

begin
  If GetValue(L) then
    Result:=IntTostr(L)
  else
    Result:='';
end;

function TLongintField.GetDataSize: Integer;

begin
  Result:=SizeOf(Longint);
end;

procedure TLongintField.GetText(var AText: string; ADisplayText: Boolean);

var l : longint;
    fmt : string;

begin
  Atext:='';
  If Not GetValue(l) then exit;
  If ADisplayText or (FEditFormat='') then
    fmt:=FDisplayFormat
  else
    fmt:=FEditFormat;
  If length(fmt)<>0 then
    AText:=FormatFloat(fmt,L)
  else
    Str(L,AText);
end;

function TLongintField.GetValue(var AValue: Longint): Boolean;

Var L : Longint;
    P : PLongint;

begin
  P:=@L;
  Result:=GetData(P);
  If Result then
    Case Datatype of
      ftInteger,ftAutoinc  : AValue:=Plongint(P)^;
      ftWord               : AValue:=Pword(P)^;
      ftSmallint           : AValue:=PSmallint(P)^;
    end;
end;

procedure TLongintField.SetAsLargeint(AValue: Largeint);
begin
  if (AValue>=FMinRange) and (AValue<=FMaxRange) then
    SetAsInteger(AValue)
  else
    RangeError(AValue,FMinRange,FMaxRange);
end;

procedure TLongintField.SetAsFloat(AValue: Double);

begin
  SetAsInteger(Round(AValue));
end;

procedure TLongintField.SetAsInteger(AValue: Longint);

begin
  If CheckRange(AValue) then
    SetData(@AValue)
  else
    RangeError(AValue,FMinRange,FMaxRange);
end;

procedure TLongintField.SetVarValue(const AValue: Variant);
begin
  SetAsInteger(AValue);
end;

procedure TLongintField.SetAsString(const AValue: string);

Var L,Code : longint;

begin
  If length(AValue)=0 then
    Clear
  else
    begin
    Val(AValue,L,Code);
    If Code=0 then
      SetAsInteger(L)
    else
      DatabaseErrorFMT(SNotAnInteger,[AValue]);
    end;
end;

Function TLongintField.CheckRange(AValue : longint) : Boolean;

begin
  result := true;
  if (FMaxValue=0) then
    begin
    if (AValue>FMaxRange) Then result := false;
    end
  else
    if AValue>FMaxValue then result := false;

  if (FMinValue=0) then
    begin
    if (AValue<FMinRange) Then result := false;
    end
  else
    if AValue<FMinValue then result := false;
end;

Procedure TLongintField.SetMaxValue (AValue : longint);

begin
  If (AValue>=FMinRange) and (AValue<=FMaxRange) then
    FMaxValue:=AValue
  else
    RangeError(AValue,FMinRange,FMaxRange);
end;

Procedure TLongintField.SetMinValue (AValue : longint);

begin
  If (AValue>=FMinRange) and (AValue<=FMaxRange) then
    FMinValue:=AValue
  else
    RangeError(AValue,FMinRange,FMaxRange);
end;

{ ---------------------------------------------------------------------
    TLargeintField
  ---------------------------------------------------------------------}


constructor TLargeintField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDatatype(ftLargeint);
  FMinRange:=Low(Largeint);
  FMaxRange:=High(Largeint);
  FValidchars:=['+','-','0'..'9'];
end;

function TLargeintField.GetAsFloat: Double;

begin
  Result:=GetAsLargeint;
end;

function TLargeintField.GetAsLargeint: Largeint;

begin
  If Not GetValue(Result) then
    Result:=0;
end;

function TLargeIntField.GetAsVariant: Variant;

Var L : Largeint;

begin
  If GetValue(L) then
    Result:=L
  else
    Result:=Null;
end;

function TLargeintField.GetAsInteger: Longint;

begin
  Result:=GetAsLargeint;
end;

function TLargeintField.GetAsString: string;

Var L : Largeint;

begin
  If GetValue(L) then
    Result:=IntTostr(L)
  else
    Result:='';
end;

function TLargeintField.GetDataSize: Integer;

begin
  Result:=SizeOf(Largeint);
end;

procedure TLargeintField.GetText(var AText: string; ADisplayText: Boolean);

var l : largeint;
    fmt : string;

begin
  Atext:='';
  If Not GetValue(l) then exit;
  If ADisplayText or (FEditFormat='') then
    fmt:=FDisplayFormat
  else
    fmt:=FEditFormat;
  If length(fmt)<>0 then
    AText:=FormatFloat(fmt,L)
  else
    Str(L,AText);
end;

function TLargeintField.GetValue(var AValue: Largeint): Boolean;

type
  PLargeint = ^Largeint;

Var P : PLargeint;

begin
  P:=@AValue;
  Result:=GetData(P);
end;

procedure TLargeintField.SetAsFloat(AValue: Double);

begin
  SetAsLargeint(Round(AValue));
end;

procedure TLargeintField.SetAsLargeint(AValue: Largeint);

begin
  If CheckRange(AValue) then
    SetData(@AValue)
  else
    RangeError(AValue,FMinRange,FMaxRange);
end;

procedure TLargeintField.SetAsInteger(AValue: Longint);

begin
  SetAsLargeint(AValue);
end;

procedure TLargeintField.SetAsString(const AValue: string);

Var L     : largeint;
    code  : longint;

begin
  If length(AValue)=0 then
    Clear
  else
    begin
    Val(AValue,L,Code);
    If Code=0 then
      SetAsLargeint(L)
    else
      DatabaseErrorFMT(SNotAnInteger,[AValue]);
    end;
end;

procedure TLargeintField.SetVarValue(const AValue: Variant);
begin
  SetAsLargeint(AValue);
end;

Function TLargeintField.CheckRange(AValue : largeint) : Boolean;

begin
  result := true;
  if (FMaxValue=0) then
    begin
    if (AValue>FMaxRange) Then result := false;
    end
  else
    if AValue>FMaxValue then result := false;

  if (FMinValue=0) then
    begin
    if (AValue<FMinRange) Then result := false;
    end
  else
    if AValue<FMinValue then result := false;
end;

Procedure TLargeintField.SetMaxValue (AValue : largeint);

begin
  If (AValue>=FMinRange) and (AValue<=FMaxRange) then
    FMaxValue:=AValue
  else
    RangeError(AValue,FMinRange,FMaxRange);
end;

Procedure TLargeintField.SetMinValue (AValue : largeint);

begin
  If (AValue>=FMinRange) and (AValue<=FMaxRange) then
    FMinValue:=AValue
  else
    RangeError(AValue,FMinRange,FMaxRange);
end;

{ TSmallintField }

function TSmallintField.GetDataSize: Integer;

begin
  Result:=SizeOf(SmallInt);
end;

constructor TSmallintField.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
  SetDataType(ftSmallInt);
  FMinRange:=-32768;
  FMaxRange:=32767;
end;


{ TWordField }

function TWordField.GetDataSize: Integer;

begin
  Result:=SizeOf(Word);
end;

constructor TWordField.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
  SetDataType(ftWord);
  FMinRange:=0;
  FMaxRange:=65535;
  FValidchars:=['+','0'..'9'];
end;

{ TAutoIncField }

constructor TAutoIncField.Create(AOwner: TComponent);

begin
  Inherited Create(AOWner);
  SetDataType(ftAutoInc);
end;

Procedure TAutoIncField.SetAsInteger(AValue: Longint);

begin
  // Some databases allows insertion of explicit values into identity columns
  // (some of them also allows (some not) updating identity columns)
  // So allow it at client side and leave check for server side
  //if not(FDataSet.State in [dsFilter,dsSetKey,dsInsert]) then
  //  DataBaseError(SCantSetAutoIncFields);
  inherited;
end;

{ TFloatField }

procedure TFloatField.SetCurrency(const AValue: Boolean);
begin
  if FCurrency=AValue then exit;
  FCurrency:=AValue;
end;

procedure TFloatField.SetPrecision(const AValue: Longint);
begin
  if (AValue = -1) or (AValue > 1) then
    FPrecision := AValue
  else
    FPrecision := 2;
end;

function TFloatField.GetAsFloat: Double;

begin
  If Not GetData(@Result) Then
    Result:=0.0;
end;

function TFloatField.GetAsVariant: Variant;

Var f : Double;

begin
  If GetData(@f) then
    Result := f
  else
    Result:=Null;
end;

function TFloatField.GetAsLargeInt: LargeInt;
begin
  Result:=Round(GetAsFloat);
end;

function TFloatField.GetAsInteger: Longint;

begin
  Result:=Round(GetAsFloat);
end;

function TFloatField.GetAsString: string;

Var R : Double;

begin
  If GetData(@R) then
    Result:=FloatToStr(R)
  else
    Result:='';
end;

function TFloatField.GetDataSize: Integer;

begin
  Result:=SizeOf(Double);
end;

procedure TFloatField.GetText(var TheText: string; ADisplayText: Boolean);

Var
    fmt : string;
    E : Double;
    Digits : integer;
    ff: TFloatFormat;

begin
  TheText:='';
  If Not GetData(@E) then exit;
  If ADisplayText or (Length(FEditFormat) = 0) Then
    Fmt:=FDisplayFormat
  else
    Fmt:=FEditFormat;
    
  Digits := 0;
  if not FCurrency then
    ff := ffGeneral
  else
    begin
    Digits := CurrencyDecimals;
    if ADisplayText then
      ff := ffCurrency
    else
      ff := ffFixed;
    end;


  If fmt<>'' then
    TheText:=FormatFloat(fmt,E)
  else
    TheText:=FloatToStrF(E,ff,FPrecision,Digits);
end;

procedure TFloatField.SetAsFloat(AValue: Double);

begin
  If CheckRange(AValue) then
    SetData(@AValue)
  else
    RangeError(AValue,FMinValue,FMaxValue);
end;

procedure TFloatField.SetAsLargeInt(AValue: LargeInt);
begin
  SetAsFloat(AValue);
end;

procedure TFloatField.SetAsInteger(AValue: Longint);

begin
  SetAsFloat(AValue);
end;

procedure TFloatField.SetAsString(const AValue: string);

Var R : Double;

begin
  If (AValue='') then
    Clear
  else  
    try
      R := StrToFloat(AValue);
      SetAsFloat(R);
    except
      DatabaseErrorFmt(SNotAFloat, [AValue]);
    end;
end;

procedure TFloatField.SetVarValue(const AValue: Variant);
begin
  SetAsFloat(AValue);
end;

constructor TFloatField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDatatype(ftfloat);
  FPrecision:=15;
  FValidChars := [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
end;

Function TFloatField.CheckRange(AValue : Double) : Boolean;

begin
  If (FMinValue<>0) or (FMaxValue<>0) then
    Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
  else
    Result:=True;
end;

{ TCurrencyField }

Constructor TCurrencyField.Create(AOwner: TComponent);

begin
  inherited Create(AOwner);
  SetDataType(ftCurrency);
  Currency := True;
end;

{ TBooleanField }

function TBooleanField.GetAsBoolean: Boolean;

var b : wordbool;

begin
  If GetData(@b) then
    Result := b
  else
    Result:=False;
end;

function TBooleanField.GetAsVariant: Variant;

Var b : wordbool;

begin
  If GetData(@b) then
    Result := b
  else
    Result:=Null;
end;

function TBooleanField.GetAsString: string;

Var B : wordbool;

begin
  If GetData(@B) then
    Result:=FDisplays[False,B]
  else
    result:='';
end;

function TBooleanField.GetDataSize: Integer;

begin
  Result:=SizeOf(wordBool);
end;

function TBooleanField.GetDefaultWidth: Longint;

begin
  Result:=Length(FDisplays[false,false]);
  If Result<Length(FDisplays[false,True]) then
    Result:=Length(FDisplays[false,True]);
end;

function TBooleanField.GetAsInteger: Longint;
begin
  Result := ord(GetAsBoolean);
end;

procedure TBooleanField.SetAsInteger(AValue: Longint);
begin
  SetAsBoolean(AValue<>0);
end;

procedure TBooleanField.SetAsBoolean(AValue: Boolean);

var b : wordbool;

begin
  b := AValue;
  SetData(@b);
end;

procedure TBooleanField.SetAsString(const AValue: string);

Var Temp : string;

begin
  Temp:=UpperCase(AValue);
  if Temp='' then
    Clear
  else if pos(Temp, FDisplays[True,True])=1 then
    SetAsBoolean(True)
  else if pos(Temp, FDisplays[True,False])=1 then
    SetAsBoolean(False)
  else
    DatabaseErrorFmt(SNotABoolean,[AValue]);
end;

procedure TBooleanField.SetVarValue(const AValue: Variant);
begin
  SetAsBoolean(AValue);
end;

constructor TBooleanField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDataType(ftBoolean);
  DisplayValues:='True;False';
end;

Procedure TBooleanField.SetDisplayValues(const AValue : String);

Var I : longint;

begin
  If FDisplayValues<>AValue then
    begin
    I:=Pos(';',AValue);
    If (I<2) or (I=Length(AValue)) then
      DatabaseErrorFmt(SInvalidDisplayValues,[AValue]);
    FdisplayValues:=AValue;
    // Store display values and their uppercase equivalents;
    FDisplays[False,True]:=Copy(AValue,1,I-1);
    FDisplays[True,True]:=UpperCase(FDisplays[False,True]);
    FDisplays[False,False]:=Copy(AValue,I+1,Length(AValue)-i);
    FDisplays[True,False]:=UpperCase(FDisplays[False,False]);
    PropertyChanged(True);
    end;
end;

{ TDateTimeField }

procedure TDateTimeField.SetDisplayFormat(const AValue: string);
begin
  if FDisplayFormat<>AValue then begin
    FDisplayFormat:=AValue;
    PropertyChanged(True);
  end;
end;

function TDateTimeField.GetAsDateTime: TDateTime;

begin
  If Not GetData(@Result,False) then
    Result:=0;
end;

procedure TDateTimeField.SetVarValue(const AValue: Variant);
begin
  SetAsDateTime(AValue);
end;

function TDateTimeField.GetAsVariant: Variant;

Var d : tDateTime;

begin
  If GetData(@d,False) then
    Result := d
  else
    Result:=Null;
end;

function TDateTimeField.GetAsFloat: Double;

begin
  Result:=GetAsdateTime;
end;


function TDateTimeField.GetAsString: string;

begin
  GetText(Result,False);
end;


function TDateTimeField.GetDataSize: Integer;

begin
  Result:=SizeOf(TDateTime);
end;


procedure TDateTimeField.GetText(var TheText: string; ADisplayText: Boolean);

Var R : TDateTime;
    F : String;

begin
  If Not GetData(@R,False) then
    TheText:=''
  else
    begin
    If (ADisplayText) and (Length(FDisplayFormat)<>0) then
      F:=FDisplayFormat
    else
      Case DataType of
       ftTime : F:=LongTimeFormat;
       ftDate : F:=ShortDateFormat;
      else
       F:='c'
      end;
    TheText:=FormatDateTime(F,R);
    end;
end;


procedure TDateTimeField.SetAsDateTime(AValue: TDateTime);

begin
  SetData(@AValue,False);
end;


procedure TDateTimeField.SetAsFloat(AValue: Double);

begin
  SetAsDateTime(AValue);
end;


procedure TDateTimeField.SetAsString(const AValue: string);

Var R : TDateTime;

begin
  if AValue<>'' then
    begin
    R:=StrToDateTime(AValue);
    SetData(@R,False);
    end
  else
    SetData(Nil);
end;


constructor TDateTimeField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDataType(ftDateTime);
end;


{ TDateField }

constructor TDateField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDataType(ftDate);
end;


{ TTimeField }

constructor TTimeField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDataType(ftTime);
end;

procedure TTimeField.SetAsString(const AValue: string);
Var R : TDateTime;
begin
  if AValue='' then
    Clear    // set to NULL
  else
    begin
    R:=StrToTime(AValue);
    SetData(@R,False);
    end;
end;



{ TBinaryField }

class procedure TBinaryField.CheckTypeSize(AValue: Longint);

begin
  // Just check for really invalid stuff; actual size is
  // dependent on the record...
  If AValue<1 then
    DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
end;

function TBinaryField.GetAsBytes: TBytes;
begin
  if not GetValue(Result) then
    SetLength(Result, 0);
end;


function TBinaryField.GetAsString: string;
var B: TBytes;
begin
  if not GetValue(B) then
    Result := ''
  else
    SetString(Result, @B[0], length(B) div SizeOf(Char));
end;


function TBinaryField.GetAsVariant: Variant;
var B: TBytes;
    P: Pointer;
begin
  if not GetValue(B) then
    Result := Null
  else
  begin
    Result := VarArrayCreate([0, length(B)-1], varByte);
    P := VarArrayLock(Result);
    try
      Move(B[0], P^, length(B));
    finally
      VarArrayUnlock(Result);
    end;
  end;
end;


procedure TBinaryField.GetText(var TheText: string; ADisplayText: Boolean);

begin
  TheText:=GetAsString;
end;


function TBinaryField.GetValue(var AValue: TBytes): Boolean;
var B: TBytes;
begin
  SetLength(B, DataSize);
  Result := assigned(B) and GetData(Pointer(B), True);
  if Result then
    if DataType = ftVarBytes then
      begin
      SetLength(AValue, PWord(B)^);
      Move(B[sizeof(Word)], AValue[0], Length(AValue));
      end
    else // ftBytes
      AValue := B;
end;


procedure TBinaryField.SetAsBytes(const AValue: TBytes);
var Buf: array[0..dsMaxStringSize] of byte;
    DynBuf: TBytes;
    Len: Word;
    P: PByte;
begin
  Len := Length(AValue);
  if Len >= DataSize then
    P := @AValue[0]
  else begin
    if DataSize <= dsMaxStringSize then
      P := @Buf[0]
    else begin
      SetLength(DynBuf, DataSize);
      P := @DynBuf[0];
    end;

    if DataType = ftVarBytes then begin
      PWord(P)^ := Len;
      Move(AValue[0], P[sizeof(Word)], Len);
    end
    else begin // ftBytes
      Move(AValue[0], P^, Len);
      FillChar(P[Len], DataSize-Len, 0); // right pad with #0
    end;
  end;
  SetData(P, True)
end;


procedure TBinaryField.SetAsString(const AValue: string);
var B : TBytes;
begin
  If Length(AValue) = DataSize then
    SetData(PChar(AValue))
  else
  begin
    SetLength(B, Length(AValue) * SizeOf(Char));
    Move(AValue[1], B[0], Length(B));
    SetAsBytes(B);
  end;
end;


procedure TBinaryField.SetText(const AValue: string);

begin
  SetAsString(AValue);
end;

procedure TBinaryField.SetVarValue(const AValue: Variant);
var P: Pointer;
    B: TBytes;
    Len: integer;
begin
  if VarIsArray(AValue) then
  begin
    P := VarArrayLock(AValue);
    try
      Len := VarArrayHighBound(AValue, 1) + 1;
      SetLength(B, Len);
      Move(P^, B[0], Len);
    finally
      VarArrayUnlock(AValue);
    end;
    SetAsBytes(B);
  end
  else
    SetAsString(AValue);
end;


constructor TBinaryField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
end;



{ TBytesField }

function TBytesField.GetDataSize: Integer;

begin
  Result:=Size;
end;


constructor TBytesField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDataType(ftBytes);
  Size:=16;
end;



{ TVarBytesField }

function TVarBytesField.GetDataSize: Integer;

begin
  Result:=Size+2;
end;


constructor TVarBytesField.Create(AOwner: TComponent);

begin
  INherited Create(AOwner);
  SetDataType(ftvarbytes);
  Size:=16;
end;

{ TBCDField }

class procedure TBCDField.CheckTypeSize(AValue: Longint);

begin
  If not (AValue in [0..4]) then
    DatabaseErrorfmt(SInvalidFieldSize,[AValue]);
end;

function TBCDField.GetAsBCD: TBCD;
Var
  c:system.Currency;

begin
  If GetData(@c) then
    Result:=CurrToBCD(c)
  else
    Result:=NullBCD;
end;

function TBCDField.GetAsCurrency: Currency;

begin
  if not GetData(@Result) then
    result := 0;
end;

function TBCDField.GetAsVariant: Variant;

Var c : system.Currency;

begin
  If GetData(@c) then
    Result := c
  else
    Result:=Null;
end;

function TBCDField.GetAsFloat: Double;

begin
  result := GetAsCurrency;
end;


function TBCDField.GetAsInteger: Longint;

begin
  result := round(GetAsCurrency);
end;


function TBCDField.GetAsString: string;

var c : system.currency;

begin
  If GetData(@C) then
    Result:=CurrToStr(C)
  else
    Result:='';
end;

function TBCDField.GetValue(var AValue: Currency): Boolean;

begin
  Result := GetData(@AValue);
end;

function TBCDField.GetDataSize: Integer;

begin
  result := sizeof(system.currency);
end;

function TBCDField.GetDefaultWidth: Longint;

begin
  if precision > 0 then result := precision
    else result := 10;
end;

procedure TBCDField.GetText(var TheText: string; ADisplayText: Boolean);
var
  c : system.currency;
  fmt: String;
begin
  if GetData(@C) then begin
    if aDisplayText or (FEditFormat='') then
      fmt := FDisplayFormat
    else
      fmt := FEditFormat;
    if fmt<>'' then
      TheText := FormatFloat(fmt,C)
    else if fCurrency then begin
      if aDisplayText then
        TheText := FloatToStrF(C, ffCurrency, FPrecision, 2{digits?})
      else
        TheText := FloatToStrF(C, ffFixed, FPrecision, 2{digits?});
    end else
      TheText := FloatToStrF(C, ffGeneral, FPrecision, 0{digits?});
  end else
    TheText := '';
end;

procedure TBCDField.SetAsBCD(const AValue: TBCD);
var
  c:system.currency;
begin
  if BCDToCurr(AValue,c) then
    SetAsCurrency(c);
end;

procedure TBCDField.SetAsCurrency(AValue: Currency);

begin
  If CheckRange(AValue) then
    setdata(@AValue)
  else
    RangeError(AValue,FMinValue,FMaxValue);
end;

procedure TBCDField.SetVarValue(const AValue: Variant);
begin
  SetAsCurrency(AValue);
end;

Function TBCDField.CheckRange(AValue : Currency) : Boolean;

begin
  If (FMinValue<>0) or (FMaxValue<>0) then
    Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
  else
    Result:=True;
end;

procedure TBCDField.SetAsFloat(AValue: Double);

begin
  SetAsCurrency(AValue);
end;


procedure TBCDField.SetAsInteger(AValue: Longint);

begin
  SetAsCurrency(AValue);
end;


procedure TBCDField.SetAsString(const AValue: string);

begin
  if AValue='' then
    Clear    // set to NULL
  else
    SetAsCurrency(strtocurr(AValue));
end;

constructor TBCDField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  FMaxValue := 0;
  FMinValue := 0;
  FValidChars := [DecimalSeparator, '+', '-', '0'..'9'];
  SetDataType(ftBCD);
  FPrecision := 15;
  Size:=4;
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 := VarFMTBcdCreate(bcd)
  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.GetAsLargeInt: LargeInt;
var bcd: TBCD;
begin
  if GetData(@bcd) then
    Result := BCDToInteger(bcd)
  else
    Result := 0;
end;

function TFMTBCDField.GetAsInteger: 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;
  fmt: String;
begin
  if GetData(@bcd) then begin
    if aDisplayText or (FEditFormat='') then
      fmt := FDisplayFormat
    else
      fmt := FEditFormat;
    if fmt<>'' then
      TheText := FormatBCD(fmt,bcd)
    else if fCurrency then begin
      if aDisplayText then
        TheText := BcdToStrF(bcd, ffCurrency, FPrecision, 2)
      else
        TheText := BcdToStrF(bcd, ffFixed, FPrecision, 2);
    end else
      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);
begin
  SetAsBCD(VarToBCD(AValue));
end;

procedure TFMTBCDField.SetAsFloat(AValue: Double);
begin
  SetAsBCD(DoubleToBCD(AValue));
end;

procedure TFMTBCDField.SetAsLargeInt(AValue: LargeInt);
begin
  SetAsBCD(IntegerToBCD(AValue));
end;

procedure TFMTBCDField.SetAsInteger(AValue: Longint);
begin
  SetAsBCD(IntegerToBCD(AValue));
end;

procedure TFMTBCDField.SetAsString(const AValue: string);
begin
  if AValue='' then
    Clear    // set to NULL
  else
    SetAsBCD(StrToBCD(AValue));
end;


{ TBlobField }

function TBlobField.GetBlobStream(Mode: TBlobStreamMode): TStream;

begin
  Result:=FDataset.CreateBlobStream(Self,Mode);
end;

procedure TBlobField.FreeBuffers;

begin
end;

function TBlobField.GetAsBytes: TBytes;
var
  Stream : TStream;
  Len    : Integer;
begin
  Stream := GetBlobStream(bmRead);
  if Stream <> nil then
    try
      Len := Stream.Size;
      SetLength(Result, Len);
      if Len > 0 then
        Stream.ReadBuffer(Result[0], Len);
    finally
      Stream.Free;
    end
  else
    SetLength(Result, 0);
end;

function TBlobField.GetAsString: string;
var
  Stream : TStream;
  Len    : Integer;
begin
  Stream := GetBlobStream(bmRead);
  if Stream <> nil then
    with Stream do
      try
        Len := Size;
        SetLength(Result, Len);
        if Len > 0 then
          ReadBuffer(Result[1], Len);
      finally
        Free
      end
  else
    Result := '';
end;

function TBlobField.GetAsWideString: WideString;
var
  Stream : TStream;
  Len    : Integer;
begin
  Stream := GetBlobStream(bmRead);
  if Stream <> nil then
    with Stream do
      try
        Len := Size;
        SetLength(Result, (Len+1) div 2);
        if Len > 0 then
          ReadBuffer(Result[1] ,Len);
      finally
        Free
      end
  else
    Result := '';
end;

function TBlobField.GetAsVariant: Variant;

Var s : string;

begin
  if not GetIsNull then
    begin
    s := GetAsString;
    result := s;
    end
  else
    result := Null;
end;


function TBlobField.GetBlobSize: Longint;
var
  Stream: TStream;
begin
  Stream := GetBlobStream(bmRead);
  if Stream <> nil then
    with Stream do
      try
        Result:=Size;
      finally
        Free;
      end
  else
    Result := 0;
end;


function TBlobField.GetIsNull: Boolean;

begin
  if Not Modified then
    Result:= inherited GetIsNull
  else
    with GetBlobStream(bmRead) do
      try
        Result:=(Size=0);
      finally
        Free;
      end;
end;


procedure TBlobField.GetText(var TheText: string; ADisplayText: Boolean);

begin
  TheText:=inherited GetAsString;
end;

procedure TBlobField.SetAsBytes(const AValue: TBytes);
var
  Len : Integer;
begin
  with GetBlobStream(bmWrite) do
    try
      Len := Length(AValue);
      if Len > 0 then
        WriteBuffer(AValue[0], Len);
    finally
      Free;
    end;
end;


procedure TBlobField.SetAsString(const AValue: string);
var
  Len : Integer;
begin
  with GetBlobStream(bmWrite) do
    try
      Len := Length(AValue);
      if Len > 0 then
        WriteBuffer(AValue[1], Len);
    finally
      Free;
    end;
end;


procedure TBlobField.SetAsWideString(const AValue: WideString);
var
  Len : Integer;
begin
  with GetBlobStream(bmWrite) do
    try
      Len := Length(AValue) * 2;
      if Len > 0 then
        WriteBuffer(AValue[1], Len);
    finally
      Free;
    end;
end;


procedure TBlobField.SetText(const AValue: string);

begin
  SetAsString(AValue);
end;

procedure TBlobField.SetVarValue(const AValue: Variant);
begin
  SetAsString(AValue);
end;


constructor TBlobField.Create(AOwner: TComponent);

begin
  Inherited Create(AOWner);
  SetDataType(ftBlob);
end;


procedure TBlobField.Clear;

begin
  GetBlobStream(bmWrite).free;
end;


class function TBlobField.IsBlob: Boolean;

begin
  Result:=True;
end;


procedure TBlobField.LoadFromFile(const FileName: string);

Var S : TFileStream;

begin
  S:=TFileStream.Create(FileName,fmOpenRead);
  try
    LoadFromStream(S);
  finally
    S.Free;
  end;
end;


procedure TBlobField.LoadFromStream(Stream: TStream);

begin
  with GetBlobStream(bmWrite) do
    try
      CopyFrom(Stream,0);
    finally
      Free;
    end;
end;


procedure TBlobField.SaveToFile(const FileName: string);

Var S : TFileStream;

begin
  S:=TFileStream.Create(FileName,fmCreate);
  try
    SaveToStream(S);
  finally
    S.Free;
  end;
end;


procedure TBlobField.SaveToStream(Stream: TStream);

Var S : TStream;

begin
  S:=GetBlobStream(bmRead);
  Try
    If Assigned(S) then
      Stream.CopyFrom(S,0);
  finally
    S.Free;
  end;
end;

procedure TBlobField.SetFieldType(AValue: TFieldType);

begin
  If AValue in [Low(TBlobType)..High(TBlobType)] then
    SetDatatype(AValue);
end;

{ TMemoField }

constructor TMemoField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDataType(ftMemo);
end;

function TMemoField.GetAsWideString: WideString;
begin
  Result := GetAsString;
end;

procedure TMemoField.SetAsWideString(const AValue: WideString);
begin
  SetAsString(AValue);
end;

{ TWideMemoField }

constructor TWideMemoField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftWideMemo);
end;

function TWideMemoField.GetAsString: string;
begin
  Result := GetAsWideString;
end;

procedure TWideMemoField.SetAsString(const AValue: string);
begin
  SetAsWideString(AValue);
end;

function TWideMemoField.GetAsVariant: Variant;

Var s : string;

begin
  if not GetIsNull then
    begin
    s := GetAsWideString;
    result := s;
    end
  else result := Null;
end;

procedure TWideMemoField.SetVarValue(const AValue: Variant);
begin
  SetAsWideString(AValue);
end;

{ TGraphicField }

constructor TGraphicField.Create(AOwner: TComponent);

begin
  Inherited Create(AOwner);
  SetDataType(ftGraphic);
end;

{ TGuidField }

constructor TGuidField.Create(AOwner: TComponent);
begin
  Size := 38;
  inherited Create(AOwner);
  SetDataType(ftGuid);
end;

class procedure TGuidField.CheckTypeSize(AValue: LongInt);
begin
  if AValue <> 38 then
    DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
end;

function TGuidField.GetAsGuid: TGUID;
const
  nullguid: TGUID = '{00000000-0000-0000-0000-000000000000}';
var
  S: string;
begin
  S := GetAsString;
  if S = '' then
    Result := nullguid
  else
    Result := StringToGuid(S);
end;

function TGuidField.GetDefaultWidth: LongInt;
begin
  Result := 38;
end;

procedure TGuidField.SetAsGuid(const AValue: TGUID);
begin
  SetAsString(GuidToString(AValue));
end;

function TVariantField.GetDefaultWidth: Integer;
begin
  Result := 15;
end;

{ TVariantField }

constructor TVariantField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftVariant);
end;

class procedure TVariantField.CheckTypeSize(aValue: Integer);
begin
  { empty }
end;

function TVariantField.GetAsBoolean: Boolean;
begin
  Result := GetAsVariant;
end;

function TVariantField.GetAsDateTime: TDateTime;
begin
  Result := GetAsVariant;
end;

function TVariantField.GetAsFloat: Double;
begin
  Result := GetAsVariant;
end;

function TVariantField.GetAsInteger: Longint;
begin
  Result := GetAsVariant;
end;

function TVariantField.GetAsString: string;
begin
  Result := VarToStr(GetAsVariant);
end;

function TVariantField.GetAsWideString: WideString;
begin
  Result := VarToWideStr(GetAsVariant);
end;

function TVariantField.GetAsVariant: Variant;
begin
  if not GetData(@Result) then
    Result := Null;
end;

procedure TVariantField.SetAsBoolean(aValue: Boolean);
begin
  SetVarValue(aValue);
end;

procedure TVariantField.SetAsDateTime(aValue: TDateTime);
begin
  SetVarValue(aValue);
end;

procedure TVariantField.SetAsFloat(aValue: Double);
begin
  SetVarValue(aValue);
end;

procedure TVariantField.SetAsInteger(AValue: Longint);
begin
  SetVarValue(aValue);
end;

procedure TVariantField.SetAsString(const aValue: string);
begin
  SetVarValue(aValue);
end;

procedure TVariantField.SetAsWideString(const aValue: WideString);
begin
  SetVarValue(aValue);
end;

procedure TVariantField.SetVarValue(const aValue: Variant);
begin
  SetData(@aValue);
end;

{ TFieldsEnumerator }

function TFieldsEnumerator.GetCurrent: TField;
begin
  Result := FFields[FPosition];
end;

constructor TFieldsEnumerator.Create(AFields: TFields);
begin
  inherited Create;
  FFields := AFields;
  FPosition := -1;
end;

function TFieldsEnumerator.MoveNext: Boolean;
begin
  inc(FPosition);
  Result := FPosition < FFields.Count;
end;

{ TFields }

Constructor TFields.Create(ADataset : TDataset);

begin
  FDataSet:=ADataset;
  FFieldList:=TFpList.Create;
  FValidFieldKinds:=[fkData..fkInternalcalc];
end;

Destructor TFields.Destroy;

begin
  if Assigned(FFieldList) then
    Clear;
  FreeAndNil(FFieldList);
  inherited Destroy;
end;

Procedure Tfields.Changed;

begin
  if (FDataSet <> nil) and not (csDestroying in FDataSet.ComponentState) and FDataset.Active then
    FDataSet.DataEvent(deFieldListChange, 0);
  If Assigned(FOnChange) then
    FOnChange(Self);
end;

Procedure TFields.CheckfieldKind(Fieldkind : TFieldKind; Field : TField);

begin
  If Not (FieldKind in ValidFieldKinds) Then
    DatabaseErrorFmt(SInvalidFieldKind,[Field.FieldName]);
end;

Function Tfields.GetCount : Longint;

begin
  Result:=FFieldList.Count;
end;


Function TFields.GetField (Index : longint) : TField;

begin
  Result:=Tfield(FFieldList[Index]);
end;

procedure Tfields.SetField(Index: Integer; Value: TField);
begin
  Fields[Index].Assign(Value);
end;

Procedure TFields.SetFieldIndex (Field : TField;Value : Integer);

Var Old : Longint;

begin
  Old := FFieldList.indexOf(Field);
  If Old=-1 then
    Exit;
  // Check value
  If Value<0 Then Value:=0;
  If Value>=Count then Value:=Count-1;
  If Value<>Old then
    begin
    FFieldList.Delete(Old);
    FFieldList.Insert(Value,Field);
    Field.PropertyChanged(True);
    Changed;
    end;
end;

Procedure TFields.Add(Field : TField);

begin
  CheckFieldName(Field.FieldName);
  FFieldList.Add(Field);
  Field.FFields:=Self;
  Changed;
end;

Procedure TFields.CheckFieldName (Const Value : String);

begin
  If FindField(Value)<>Nil then
    DataBaseErrorFmt(SDuplicateFieldName,[Value],FDataset);
end;

Procedure TFields.CheckFieldNames (Const Value : String);


Var I : longint;
    S,T : String;
begin
  T:=Value;
  Repeat
    I:=Pos(';',T);
    If I=0 Then I:=Length(T)+1;
    S:=Copy(T,1,I-1);
    Delete(T,1,I);
    // Will raise an error if no such field...
    FieldByName(S);
  Until (T='');
end;

Procedure TFields.Clear;
var
  AField: TField;
begin
  while FFieldList.Count > 0 do 
    begin
    AField := TField(FFieldList.Last);
    AField.FDataSet := Nil;
    AField.Free;
    FFieldList.Delete(FFieldList.Count - 1);
    end;
  Changed;
end;

Function TFields.FindField (Const Value : String) : TField;

Var S : String;
    I : longint;

begin
  Result:=Nil;
  S:=UpperCase(Value);
  For I:=0 To FFieldList.Count-1 do
    If S=UpperCase(TField(FFieldList[i]).FieldName) Then
      Begin
      {$ifdef dsdebug}
      Writeln ('Found field ',Value);
      {$endif}
      Result:=TField(FFieldList[I]);
      Exit;
      end;
end;

Function TFields.FieldByName (Const Value : String) : TField;

begin
  Result:=FindField(Value);
  If result=Nil then
    DatabaseErrorFmt(SFieldNotFound,[Value],FDataset);
end;

Function TFields.FieldByNumber(FieldNo : Integer) : TField;

Var i : Longint;

begin
  Result:=Nil;
  For I:=0 to FFieldList.Count-1 do
    If FieldNo=TField(FFieldList[I]).FieldNo then
      begin
      Result:=TField(FFieldList[i]);
      Exit;
      end;
end;

Function TFields.GetEnumerator: TFieldsEnumerator;

begin
  Result:=TFieldsEnumerator.Create(Self);
end;

Procedure TFields.GetFieldNames (Values : TStrings);

Var i : longint;

begin
  Values.Clear;
  For I:=0 to FFieldList.Count-1 do
    Values.Add(Tfield(FFieldList[I]).FieldName);
end;

Function TFields.IndexOf(Field : TField) : Longint;

begin
  Result:=FFieldList.IndexOf(Field);
end;

procedure TFields.Remove(Value : TField);

begin
  FFieldList.Remove(Value);
  Value.FFields := nil;
  Changed;
end;

fields.inc (68,067 bytes)

Reinier Olislagers

2014-05-06 08:34

developer   ~0074802

Workaround for first part of bug in Lazarus 1.2.2 (which ships with FPC 2.6.4):
1. copy all files from $(lazarusdir)\fpc\2.6.4\source\packages\fcl-db\src\base to your project directory
2. apply the 2 changes mentioned above (r27691,27717) to db.pas or download the fields.inc in this bug report (http://bugs.freepascal.org/file_download.php?file_id=19958&type=bug) to your project directory, overwriting the copied db.pas
3. recompile your project (probably best to do a rebuild and clean)

For the second part of the bug, you could follow a similar approach for revision 27738, sqldb.pp and related files

Mentioned bug and workaround in http://wiki.lazarus.freepascal.org/Lazarus_1.2_fixes_branch#Fixes_for_1.2.2_.28Merged.29

Please test workaround and close if ok.

Sorry for the inconvenience.

Reinier Olislagers

2014-09-09 08:50

developer   ~0076992

No feedback in a reasonable timeframe.

Reinier Olislagers

2014-09-14 09:48

developer  

firebird_fpc2.6.4.txt (14,622 bytes)
 N:265 E:4 F:0 I:15
  TTestBasics N:7 E:0 F:0 I:0
    TestParseSQL
    TestInitFielddefsFromFields
    TestDoubleFieldDef
    TestFieldDefWithoutDS
    TestGetParamList
    TestGetFieldList
    TestExtractFieldName
  TTestFieldTypes N:75 E:3 F:0 I:7
    TestEmptyUpdateQuery
    TestParseJoins
    TestParseUnion
    TestDoubleFieldNames
    TestNumericNames
    TestApplyUpdFieldnames
    TestStringLargerThen8192
    TestInsertLargeStrFields  Error: EAccessViolation
      Exception:   Access violation
      Source unit: 
      Method name: 
      Line number: 0
    TestLargeRecordSize  Error: EAccessViolation
      Exception:   Access violation
      Source unit: 
      Method name: 
      Line number: 0
    TestClearUpdateableStatus  Ignored test: This test does only apply to MySQL because the used SQL-statement is MySQL only.
    TestReadOnlyParseSQL
    TestpfInUpdateFlag
    TestAggregates
    TestServerFilter
    Test11Params
    TestRowsAffected
    TestLocateNull
    TestLocateOnMoreRecords
    TestStringsReplace
    TestCircularParams
    TestBug9744
    TestCrossStringDateParam  Error: EVariantError
      Exception:   Invalid variant type cast
      Source unit: 
      Method name: 
      Line number: 0
    TestSetBlobAsMemoParam
    TestSetBlobAsBlobParam
    TestSetBlobAsStringParam
    TestNonNullableParams
    TestDblQuoteEscComments
    TestInsertReturningQuery
    TestOpenStoredProc
    TestTemporaryTable
    TestRefresh
    TestQueryAfterReconnect
    TestParametersAndDates  Ignored test: This test does not apply to this sqldb-connection type, since it doesn't use semicolons for casts
    TestExceptOnsecClose
    TestErrorOnEmptyStatement
    TestBlob
    TestChangeBlob
    TestBlobGetText
    TestBlobSize
    TestInt
    TestTinyint
    TestNumeric
    TestFloat
    TestDate
    TestDateTime
    TestString
    TestUnlVarChar  Ignored test: This test does only apply to Postgres, since others don't support varchars without length given
    TestNullValues
    TestParamQuery
    TestStringParamQuery
    TestFixedStringParamQuery
    TestDateParamQuery
    TestSmallIntParamQuery
    TestIntParamQuery
    TestLargeIntParamQuery
    TestTimeParamQuery
    TestDateTimeParamQuery
    TestFmtBCDParamQuery
    TestFloatParamQuery
    TestBCDParamQuery
    TestBytesParamQuery  Ignored test: Fields of the type Bytes are not supported by this sqldb-connection type
    TestVarBytesParamQuery  Ignored test: Fields of the type VarBytes are not supported by this sqldb-connection type
    TestBooleanParamQuery  Ignored test: Fields of the type Boolean are not supported by this sqldb-connection type
    TestTableNames
    TestGetTables
    TestFieldNames
    TestGetFieldNames
    TestUpdateIndexDefs
    TestMultipleFieldPKIndexDefs
    TestGetIndexDefs
    TestSQLClob
    TestSQLLargeint
    TestSQLInterval
    TestSQLIdentity  Ignored test: This test does not apply to this sqldb-connection type
    TestSQLReal
  TTestDBBasics N:33 E:0 F:0 I:3
    TestSetFieldValues
    TestGetFieldValues
    TestSupportIntegerFields
    TestSupportSmallIntFields
    TestSupportWordFields  Ignored test: Fields of the type Word are not supported by this type of dataset
    TestSupportStringFields
    TestSupportBooleanFields  Ignored test: Fields of the type Boolean are not supported by this type of dataset
    TestSupportFloatFields
    TestSupportLargeIntFields
    TestSupportDateFields
    TestSupportTimeFields
    TestSupportCurrencyFields  Ignored test: Fields of the type Currency are not supported by this type of dataset
    TestSupportBCDFields
    TestSupportfmtBCDFields
    TestSupportFixedStringFields
    TestSupportBlobFields
    TestSupportMemoFields
    TestDoubleClose
    TestCalculatedField
    TestAssignFieldftString
    TestAssignFieldftFixedChar
    TestSelectQueryBasics
    TestPostOnlyInEditState
    TestMove
    TestActiveBufferWhenClosed
    TestEOFBOFClosedDataset
    TestLayoutChangedEvents
    TestDataEventsResync
    TestRecordcountAfterReopen
    TestdeFieldListChange
    TestExceptionLocateClosed
    TestCanModifySpecialFields
    TestDetectionNonMatchingDataset
  TTestCursorDBBasics N:28 E:0 F:0 I:0
    TestCancelUpdDelete1
    TestCancelUpdDelete2
    TestAppendInsertRecord
    TestBookmarks
    TestBookmarkValid
    TestDelete1
    TestDelete2
    TestLocate
    TestLocateCaseIns
    TestLocateCaseInsInts
    TestLookup
    TestFirst
    TestIntFilter
    TestOnFilter
    TestStringFilter
    TestNullAtOpen
    TestAppendOnEmptyDataset
    TestInsertOnEmptyDataset
    TestEofAfterFirst
    TestLastAppendCancel
    TestRecNo
    TestSetRecNo
    TestBug7007
    TestBug6893
    TestRequired
    TestOldValueObsolete
    TestOldValue
    TestModified
  TTestBufDatasetDBBasics N:31 E:0 F:0 I:2
    TestClosedIndexFieldNames
    TestFileNameProperty
    TestClientDatasetAsMemDataset
    TestSaveAsXML
    TestIsEmpty
    TestBufDatasetCancelUpd
    TestBufDatasetCancelUpd1
    TestMultipleDeleteUpdateBuffer
    TestDoubleDelete
    TestReadOnly
    TestMergeChangeLog
    TestAddIndexInteger
    TestAddIndexSmallInt
    TestAddIndexBoolean  Ignored test: Fields of the type Boolean are not supported by this type of dataset
    TestAddIndexFloat
    TestAddIndexLargeInt
    TestAddIndexDateTime
    TestAddIndexCurrency  Ignored test: Fields of the type Currency are not supported by this type of dataset
    TestAddIndexBCD
    TestAddIndex
    TestAddDescIndex
    TestAddCaseInsIndex
    TestInactSwitchIndex
    TestAddIndexActiveDS
    TestAddIndexEditDS
    TestIndexFieldNames
    TestIndexFieldNamesAct
    TestIndexCurRecord
    TestAddDblIndex
    TestIndexEditRecord
    TestIndexAppendRecord
  TTestUniDirectionalDBBasics N:33 E:0 F:0 I:3
    TestSetFieldValues
    TestGetFieldValues
    TestSupportIntegerFields
    TestSupportSmallIntFields
    TestSupportWordFields  Ignored test: Fields of the type Word are not supported by this type of dataset
    TestSupportStringFields
    TestSupportBooleanFields  Ignored test: Fields of the type Boolean are not supported by this type of dataset
    TestSupportFloatFields
    TestSupportLargeIntFields
    TestSupportDateFields
    TestSupportTimeFields
    TestSupportCurrencyFields  Ignored test: Fields of the type Currency are not supported by this type of dataset
    TestSupportBCDFields
    TestSupportfmtBCDFields
    TestSupportFixedStringFields
    TestSupportBlobFields
    TestSupportMemoFields
    TestDoubleClose
    TestCalculatedField
    TestAssignFieldftString
    TestAssignFieldftFixedChar
    TestSelectQueryBasics
    TestPostOnlyInEditState
    TestMove
    TestActiveBufferWhenClosed
    TestEOFBOFClosedDataset
    TestLayoutChangedEvents
    TestDataEventsResync
    TestRecordcountAfterReopen
    TestdeFieldListChange
    TestExceptionLocateClosed
    TestCanModifySpecialFields
    TestDetectionNonMatchingDataset
  TTestBufDatasetStreams N:34 E:1 F:0 I:0
    TestSimpleEditCancelUpd
    TestSimpleDeleteCancelUpd
    TestMoreDeletesCancelUpd
    TestSimpleInsertCancelUpd
    MoreInsertsCancelUpd
    SeveralEditsCancelUpd
    DeleteAllCancelUpd
    DeleteAllInsertCancelUpd
    AppendDeleteCancelUpd
    TestSimpleEditApplUpd
    TestSimpleDeleteApplUpd
    TestMoreDeletesApplUpd
    TestSimpleInsertApplUpd
    MoreInsertsApplUpd
    SeveralEditsApplUpd
    DeleteAllApplUpd
    DeleteAllInsertApplUpd
    NullInsertUpdateApplUpd
    TestBasicsXML
    TestSimpleEditXML
    TestSimpleDeleteXML
    TestMoreDeletesXML
    TestSimpleInsertXML
    TestMoreInsertsXML
    TestSeveralEditsXML
    TestDeleteAllXML
    TestDeleteAllInsertXML
    TestStreamingBlobFieldsXML
    TestStreamingBigBlobFieldsXML  Error: EAccessViolation
      Exception:   Access violation
      Source unit: 
      Method name: 
      Line number: 0
    TestStreamingCalculatedFieldsXML
    TestAppendDeleteBIN
    TestFileNameProperty
    TestXmlFileRecognition
    TestCloseDatasetNoConnection
  TTestTSQLQuery N:2 E:0 F:0 I:0
    TestMasterDetail
    TestUpdateServerIndexDefs
  TTestTSQLConnection N:1 E:0 F:0 I:0
    ReplaceMe
  TTestTSQLScript N:1 E:0 F:0 I:0
    TestExecuteScript
  TTestDBExport N:20 E:0 F:0 I:0
    TestDBFExport_DBaseIV
    TestDBFExport_DBaseVII
    TestDBFExport_FoxPro
    TestCSVExport
    TestCSVExport_RFC4180WithHeader
    TestCSVExport_TweakSettingsSemicolon
    TestFixedTextExport
    TestJSONExport
    TestRTFExport
    TestSQLExport
    TestTeXExport
    TestXMLExport
    TestXSDExport_Access_NoXSD_DecimalOverride
    TestXSDExport_Access_NoXSD_NoDecimalOverride
    TestXSDExport_Access_XSD_DecimalOverride
    TestXSDExport_Access_XSD_NoDecimalOverride
    TestXSDExport_ADONET_NoXSD
    TestXSDExport_ADONET_XSD
    TestXSDExport_DelphiClientDataset
    TestXSDExport_Excel

Number of run tests: 265
Number of errors:    4
Number of failures:  0

List of errors:
  Error: 
    Message:           TTestFieldTypes.TestInsertLargeStrFields: Access violation
    Exception class:   EAccessViolation
    Exception message: Access violation
    Source unitname:   
    Line number:       0
    Failed methodname: 

  Error: 
    Message:           TTestFieldTypes.TestLargeRecordSize: Access violation
    Exception class:   EAccessViolation
    Exception message: Access violation
    Source unitname:   
    Line number:       0
    Failed methodname: 

  Error: 
    Message:           TTestFieldTypes.TestCrossStringDateParam: Invalid variant type cast
    Exception class:   EVariantError
    Exception message: Invalid variant type cast
    Source unitname:   
    Line number:       0
    Failed methodname: 

  Error: 
    Message:           TTestBufDatasetStreams.TestStreamingBigBlobFieldsXML: Access violation
    Exception class:   EAccessViolation
    Exception message: Access violation
    Source unitname:   
    Line number:       0
    Failed methodname: 


List of ignored tests:
  Ignored test: 
    Message:           TTestFieldTypes.TestClearUpdateableStatus: This test does only apply to MySQL because the used SQL-statement is MySQL only.
    Exception class:   EIgnoredTest
    Exception message: This test does only apply to MySQL because the used SQL-statement is MySQL only.
  Ignored test: 
    Message:           TTestFieldTypes.TestParametersAndDates: This test does not apply to this sqldb-connection type, since it doesn't use semicolons for casts
    Exception class:   EIgnoredTest
    Exception message: This test does not apply to this sqldb-connection type, since it doesn't use semicolons for casts
  Ignored test: 
    Message:           TTestFieldTypes.TestUnlVarChar: This test does only apply to Postgres, since others don't support varchars without length given
    Exception class:   EIgnoredTest
    Exception message: This test does only apply to Postgres, since others don't support varchars without length given
  Ignored test: 
    Message:           TTestFieldTypes.TestBytesParamQuery: Fields of the type Bytes are not supported by this sqldb-connection type
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Bytes are not supported by this sqldb-connection type
  Ignored test: 
    Message:           TTestFieldTypes.TestVarBytesParamQuery: Fields of the type VarBytes are not supported by this sqldb-connection type
    Exception class:   EIgnoredTest
    Exception message: Fields of the type VarBytes are not supported by this sqldb-connection type
  Ignored test: 
    Message:           TTestFieldTypes.TestBooleanParamQuery: Fields of the type Boolean are not supported by this sqldb-connection type
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Boolean are not supported by this sqldb-connection type
  Ignored test: 
    Message:           TTestFieldTypes.TestSQLIdentity: This test does not apply to this sqldb-connection type
    Exception class:   EIgnoredTest
    Exception message: This test does not apply to this sqldb-connection type
  Ignored test: 
    Message:           TTestDBBasics.TestSupportWordFields: Fields of the type Word are not supported by this type of dataset
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Word are not supported by this type of dataset
  Ignored test: 
    Message:           TTestDBBasics.TestSupportBooleanFields: Fields of the type Boolean are not supported by this type of dataset
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Boolean are not supported by this type of dataset
  Ignored test: 
    Message:           TTestDBBasics.TestSupportCurrencyFields: Fields of the type Currency are not supported by this type of dataset
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Currency are not supported by this type of dataset
  Ignored test: 
    Message:           TTestBufDatasetDBBasics.TestAddIndexBoolean: Fields of the type Boolean are not supported by this type of dataset
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Boolean are not supported by this type of dataset
  Ignored test: 
    Message:           TTestBufDatasetDBBasics.TestAddIndexCurrency: Fields of the type Currency are not supported by this type of dataset
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Currency are not supported by this type of dataset
  Ignored test: 
    Message:           TTestUniDirectionalDBBasics.TestSupportWordFields: Fields of the type Word are not supported by this type of dataset
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Word are not supported by this type of dataset
  Ignored test: 
    Message:           TTestUniDirectionalDBBasics.TestSupportBooleanFields: Fields of the type Boolean are not supported by this type of dataset
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Boolean are not supported by this type of dataset
  Ignored test: 
    Message:           TTestUniDirectionalDBBasics.TestSupportCurrencyFields: Fields of the type Currency are not supported by this type of dataset
    Exception class:   EIgnoredTest
    Exception message: Fields of the type Currency are not supported by this type of dataset



firebird_fpc2.6.4.txt (14,622 bytes)

Reinier Olislagers

2014-09-14 09:49

developer   ~0077205

Uploaded Firebird dbtestframework output on FPC 2.6.4 for documentation.

Reinier Olislagers

2014-09-14 09:49

developer   ~0077206

Fixed in FPC trunk; not in the 2.6.x branch

Issue History

Date Modified Username Field Change
2014-04-24 20:18 Branislav New Issue
2014-04-24 20:18 Branislav File Added: FirebirdTest.zip
2014-04-24 23:29 Luiz Americo Note Added: 0074576
2014-04-25 00:57 Maxim Ganetsky Project Lazarus => FPC
2014-04-25 04:58 Branislav Note Added: 0074578
2014-04-28 13:52 Branislav Note Edited: 0074578 View Revisions
2014-05-01 16:16 Reinier Olislagers Note Added: 0074727
2014-05-01 16:40 Reinier Olislagers Note Edited: 0074727 View Revisions
2014-05-05 12:40 LacaK Note Added: 0074777
2014-05-06 08:12 Reinier Olislagers Relationship added related to 0026113
2014-05-06 08:32 Reinier Olislagers File Added: fields.inc
2014-05-06 08:34 Reinier Olislagers Fixed in Revision => 27691 27717 27738
2014-05-06 08:34 Reinier Olislagers Note Added: 0074802
2014-05-06 08:34 Reinier Olislagers Status new => resolved
2014-05-06 08:34 Reinier Olislagers Fixed in Version => 2.7.1
2014-05-06 08:34 Reinier Olislagers Resolution open => fixed
2014-05-06 08:34 Reinier Olislagers Assigned To => Reinier Olislagers
2014-05-06 08:34 Reinier Olislagers Target Version => 2.6.5
2014-09-09 08:50 Reinier Olislagers Note Added: 0076992
2014-09-09 08:50 Reinier Olislagers Status resolved => closed
2014-09-14 09:48 Reinier Olislagers Status closed => feedback
2014-09-14 09:48 Reinier Olislagers Resolution fixed => reopened
2014-09-14 09:48 Reinier Olislagers Target Version 2.6.5 => 2.8.0
2014-09-14 09:48 Reinier Olislagers File Added: firebird_fpc2.6.4.txt
2014-09-14 09:49 Reinier Olislagers Note Added: 0077205
2014-09-14 09:49 Reinier Olislagers Note Added: 0077206
2014-09-14 09:49 Reinier Olislagers Status feedback => closed
2014-09-14 09:49 Reinier Olislagers Resolution reopened => fixed
2014-09-14 09:51 Reinier Olislagers Tag Attached: Database
2014-09-14 09:51 Reinier Olislagers Tag Attached: Firebird
2014-09-14 09:51 Reinier Olislagers Tag Attached: mysql
2014-09-14 09:51 Reinier Olislagers Tag Attached: postgres
2014-09-14 09:51 Reinier Olislagers Tag Attached: dbtestframework
2018-05-17 14:55 Michl Relationship added related to 0028673