dbf_fields.pas

tDBF is new ver, this is BDS 2007 insta

begin
  Result := TDbfFieldDefs(Collection).DbfVersion;
end;

procedure TDbfFieldDef.SetFieldType(lFieldType: tFieldType);
begin
  FFieldType := lFieldType;
  VCLToNative;
  SetDefaultSize;
end;

procedure TDbfFieldDef.SetNativeFieldType(lFieldType: tDbfFieldType);
begin
  // get uppercase field type
  if (lFieldType >= 'a') and (lFieldType <= 'z') then
    lFieldType := Chr(Ord(lFieldType)-32);
  FNativeFieldType := lFieldType;
  NativeToVCL;
  CheckSizePrecision;
end;

procedure TDbfFieldDef.SetSize(lSize: Integer);
begin
  FSize := lSize;
  CheckSizePrecision;
end;

procedure TDbfFieldDef.SetPrecision(lPrecision: Integer);
begin
  FPrecision := lPrecision;
  CheckSizePrecision;
end;

procedure TDbfFieldDef.NativeToVCL;
begin
  case FNativeFieldType of
// OH 2000-11-15 dBase7 support.
// Add the new fieldtypes
    '+' : 
      if DbfVersion = xBaseVII then
        FFieldType := ftAutoInc;
    'I' : FFieldType := ftInteger;
    'O' : FFieldType := ftFloat;
    '@', 'T':
          FFieldType := ftDateTime;
    'C',
    #$91  {Russian 'C'}
        : FFieldType := ftString;
    'L' : FFieldType := ftBoolean;
    'F', 'N':
      begin
        if (FPrecision = 0) then
        begin
          if FSize <= DIGITS_SMALLINT then
            FFieldType := ftSmallInt
          else
          if FSize <= DIGITS_INTEGER then
            FFieldType := ftInteger
          else
{$ifdef SUPPORT_INT64}
            FFieldType := ftLargeInt;
{$else}
            FFieldType := ftFloat;
{$endif}
        end else begin
          FFieldType := ftFloat;
        end;
      end;
    'D' : FFieldType := ftDate;
    'M' : FFieldType := ftMemo;
    'B' : 
      if DbfVersion = xFoxPro then
        FFieldType := ftFloat
      else
        FFieldType := ftBlob;
    'G' : FFieldType := ftDBaseOle;
    'Y' :
      if DbfGlobals.CurrencyAsBCD then
        FFieldType := ftBCD
      else
        FFieldType := ftCurrency;
    '0' : FFieldType := ftBytes;	{ Visual FoxPro ``_NullFlags'' }
  else
    FNativeFieldType := #0;
    FFieldType := ftUnknown;
  end; //case
end;

procedure TDbfFieldDef.VCLToNative;
begin
  FNativeFieldType := #0;
  case FFieldType of
    ftAutoInc  : FNativeFieldType  := '+';
    ftDateTime :
      if DbfVersion = xBaseVII then
        FNativeFieldType := '@'
      else
      if DbfVersion = xFoxPro then
        FNativeFieldType := 'T'
      else
        FNativeFieldType := 'D';
{$ifdef SUPPORT_FIELDTYPES_V4}
    ftFixedChar,
    ftWideString,
{$endif}
    ftString   : FNativeFieldType  := 'C';
    ftBoolean  : FNativeFieldType  := 'L';
    ftFloat, ftSmallInt, ftWord
{$ifdef SUPPORT_INT64}
      , ftLargeInt
{$endif}
               : FNativeFieldType := 'N';
    ftDate     : FNativeFieldType := 'D';
    ftMemo     : FNativeFieldType := 'M';
    ftBlob     : FNativeFieldType := 'B';
    ftDBaseOle : FNativeFieldType := 'G';
    ftInteger  :
      if DbfVersion = xBaseVII then
        FNativeFieldType := 'I'
      else
        FNativeFieldType := 'N';
    ftBCD, ftCurrency: 
      if DbfVersion = xFoxPro then
        FNativeFieldType := 'Y';
  end;
  if FNativeFieldType = #0 then
    raise EDbfError.CreateFmt(STRING_INVALID_VCL_FIELD_TYPE, [GetDisplayName, Ord(FFieldType)]);
end;

procedure TDbfFieldDef.SetDefaultSize;
begin
  // choose default values for variable size fields
  case FFieldType of
    ftFloat:
      begin
        FSize := 18;
        FPrecision := 8;
      end;
    ftCurrency, ftBCD:
      begin
        FSize := 8;
        FPrecision := 4;
      end;
    ftSmallInt, ftWord:
      begin
        FSize := DIGITS_SMALLINT;
        FPrecision := 0;
      end;
    ftInteger, ftAutoInc:
      begin
        if DbfVersion = xBaseVII then
          FSize := 4
        else
          FSize := DIGITS_INTEGER;
        FPrecision := 0;
      end;
{$ifdef SUPPORT_INT64}
    ftLargeInt:
      begin
        FSize := DIGITS_LARGEINT;
        FPrecision := 0;
      end;
{$endif}
    ftString {$ifdef SUPPORT_FIELDTYPES_V4}, ftFixedChar, ftWideString{$endif}:
      begin
        FSize := 30;
        FPrecision := 0;
      end;
  end; // case fieldtype

  // set sizes for fields that are restricted to single size/precision
  CheckSizePrecision;
end;

procedure TDbfFieldDef.CheckSizePrecision;
begin
  case FNativeFieldType of
    'C':
      begin
        if FSize < 0 then 
          FSize := 0;
        if DbfVersion = xFoxPro then
        begin
          if FSize >= $FFFF then 
            FSize := $FFFF;
        end else begin
          if FSize >= $FF then 
            FSize := $FF;
        end;
        FPrecision := 0;
      end;
    'L':
      begin
        FSize := 1;
        FPrecision := 0;
      end;
    'N','F':
      begin
        // floating point
        if FSize < 1   then FSize := 1;
        if FSize >= 20 then FSize := 20;
        if FPrecision > FSize-2 then FPrecision := FSize-2;
        if FPrecision < 0       then FPrecision := 0;
      end;
    'D':
      begin
        FSize := 8;
        FPrecision := 0;
      end;
    'B':
      begin
        if DbfVersion <> xFoxPro then
        begin
          FSize := 10;
          FPrecision := 0;
        end;
      end;
    'M','G':
      begin
        if DbfVersion = xFoxPro then
        begin
          if (FSize <> 4) and (FSize <> 10) then
            FSize := 4;
        end else
          FSize := 10;
        FPrecision := 0;
      end;
    '+','I':
      begin
        FSize := 4;
        FPrecision := 0;
      end;
    '@', 'O':
      begin
        FSize := 8;
        FPrecision := 0;
      end;
    'T':
      begin
        if DbfVersion = xFoxPro then
          FSize := 8
        else
          FSize := 14;
        FPrecision := 0;
      end;
    'Y':
      begin
        FSize := 8;
        FPrecision := 4;
      end;
  else
    // Nothing
  end; // case
end;

function TDbfFieldDef.GetDisplayName: string; {override;}
begin
  Result := FieldName;
end;

function TDbfFieldDef.IsBlob: Boolean; {override;}
begin
  Result := FNativeFieldType in ['M','G','B'];
end;

procedure TDbfFieldDef.FreeBuffers;
begin
  if FDefaultBuf <> nil then
  begin
    // one buffer for all
    FreeMemAndNil(Pointer(FDefaultBuf));
    FMinBuf := nil;
    FMaxBuf := nil;
  end;
  FAllocSize := 0;
end;

procedure TDbfFieldDef.AllocBuffers;
begin
  // size changed?
  if FAllocSize <> FSize then
  begin
    // free old buffers
    FreeBuffers;
    // alloc new
    GetMem(FDefaultBuf, FSize*3);
    FMinBuf := FDefaultBuf + FSize;
    FMaxBuf := FMinBuf + FSize;
    // store allocated size
    FAllocSize := FSize;
  end;
end;

end.