dbf.pas

tDBF is new ver, this is BDS 2007 insta

            Result := grOK;
          end else begin
            Result := grBOF
          end;
        end;
    end;

    if (Result = grOK) then
      Result := ReadCurrentRecord(Buffer, acceptable);

    if (Result = grOK) and acceptable then
    begin
      pRecord^.BookmarkData.PhysicalRecNo := FCursor.PhysicalRecNo;
      pRecord^.BookmarkFlag := bfCurrent;
      pRecord^.SequentialRecNo := FCursor.SequentialRecNo;
      GetCalcFields(Buffer);

      if Filtered or FFindRecordFilter then
      begin
        FFilterBuffer := Buffer;
        SaveState := SetTempState(dsFilter);
        DoFilterRecord(acceptable);
        RestoreState(SaveState);
      end;
    end;

    if (GetMode = gmCurrent) and not acceptable then
      Result := grError;
  until (Result <> grOK) or acceptable;

  if Result <> grOK then
    pRecord^.BookmarkData.PhysicalRecNo := -1;
end;

function TDbf.GetRecordSize: Word; {override virtual abstract from TDataset}
begin
  Result := FDbfFile.RecordSize;
end;

procedure TDbf.InternalAddRecord(Buffer: Pointer; AAppend: Boolean); {override virtual abstract from TDataset}
  // this function is called from TDataSet.InsertRecord and TDataSet.AppendRecord
  // goal: add record with Edit...Set Fields...Post all in one step
var
  pRecord: pDbfRecord;
  newRecord: integer;
begin
  // if InternalAddRecord is called, we know we are active
  pRecord := Buffer;

  // we can not insert records in DBF files, only append
  // ignore Append parameter
  newRecord := FDbfFile.Insert(@pRecord^.DeletedFlag);
  if newRecord > 0 then
    FCursor.PhysicalRecNo := newRecord;

  // set flag that TDataSet is about to post...so we can disable resync
  FPosting := true;
end;

procedure TDbf.InternalClose; {override virtual abstract from TDataset}
var
  lIndex: TDbfIndexDef;
  I: Integer;
begin
  // clear automatically added MDX index entries
  I := 0;
  while I < FIndexDefs.Count do
  begin
    // is this an MDX index?
    lIndex := FIndexDefs.Items[I];
    if (Length(ExtractFileExt(lIndex.IndexFile)) = 0) and
      TDbfIndexDef(FIndexDefs.Items[I]).Temporary then
    begin
{$ifdef SUPPORT_DEF_DELETE}
      // delete this entry
      FIndexDefs.Delete(I);
{$else}
      // does this work? I hope so :-)
      FIndexDefs.Items[I].Free;
{$endif}
    end else begin
      // NDX entry -> goto next
      Inc(I);
    end;
  end;

  // free blobs
  if FBlobStreams <> nil then
  begin
    for I := 0 to Pred(FieldDefs.Count) do
      FBlobStreams^[I].Free;
    FreeMemAndNil(Pointer(FBlobStreams));
  end;
  FreeRecordBuffer(FTempBuffer);
  // disconnect field objects
  BindFields(false);
  // Destroy field object (if not persistent)
  if DefaultFields then
    DestroyFields;

  if FParser <> nil then
    FreeAndNil(FParser);
  FreeAndNil(FCursor);
  if FDbfFile <> nil then
    FreeAndNil(FDbfFile);
end;

procedure TDbf.InternalCancel;
var
  I: Integer;
begin
  // cancel blobs
  for I := 0 to Pred(FieldDefs.Count) do
    if Assigned(FBlobStreams^[I]) then
      FBlobStreams^[I].Cancel;
  // if we have locked a record, unlock it
  if FEditingRecNo >= 0 then
  begin
    FDbfFile.UnlockPage(FEditingRecNo);
    FEditingRecNo := -1;
  end;
end;

procedure TDbf.InternalDelete; {override virtual abstract from TDataset}
var
  lRecord: pDbfRecord;
begin
  // start editing
  InternalEdit;
  SetState(dsEdit);
  // get record pointer
  lRecord := pDbfRecord(ActiveBuffer);
  // flag we deleted this record
  lRecord^.DeletedFlag := '*';
  // notify indexes this record is deleted
  FDbfFile.RecordDeleted(FEditingRecNo, @lRecord^.DeletedFlag);
  // done!
  InternalPost;
end;

procedure TDbf.InternalFirst; {override virtual abstract from TDataset}
begin
  FCursor.First;
end;

procedure TDbf.InternalGotoBookmark(ABookmark: Pointer); {override virtual abstract from TDataset}
begin
  with PBookmarkData(ABookmark)^ do
  begin
    if (PhysicalRecNo = 0) then begin
      First;
    end else
    if (PhysicalRecNo = MaxInt) then begin
      Last;
    end else begin
      if FCursor.PhysicalRecNo <> PhysicalRecNo then
        FCursor.PhysicalRecNo := PhysicalRecNo;
    end;
  end;
end;

procedure TDbf.InternalHandleException; {override virtual abstract from TDataset}
begin
  SysUtils.ShowException(ExceptObject, ExceptAddr);
end;

procedure TDbf.GetFieldDefsFromDbfFieldDefs;
var
  I, N: Integer;
  TempFieldDef: TDbfFieldDef;
  TempMdxFile: TIndexFile;
  BaseName, lIndexName: string;
begin
  FieldDefs.Clear;

  // get all fields
  for I := 0 to FDbfFile.FieldDefs.Count - 1 do
  begin
    TempFieldDef := FDbfFile.FieldDefs.Items[I];
    // handle duplicate field names
    N := 1;
    BaseName := TempFieldDef.FieldName;
    while FieldDefs.IndexOf(TempFieldDef.FieldName)>=0 do
    begin
      Inc(N);
      TempFieldDef.FieldName:=BaseName+IntToStr(N);
    end;
    // add field
    if TempFieldDef.FieldType in [ftString, ftBCD, ftBytes] then
      FieldDefs.Add(TempFieldDef.FieldName, TempFieldDef.FieldType, TempFieldDef.Size, false)
    else
      FieldDefs.Add(TempFieldDef.FieldName, TempFieldDef.FieldType, 0, false);

    if TempFieldDef.FieldType = ftFloat then
      FieldDefs[I].Precision := TempFieldDef.Precision;

{$ifdef SUPPORT_FIELDDEF_ATTRIBUTES}
    // AutoInc fields are readonly
    if TempFieldDef.FieldType = ftAutoInc then
      FieldDefs[I].Attributes := [Db.faReadOnly];

    // if table has dbase lock field, then hide it
    if TempFieldDef.IsLockField then
      FieldDefs[I].Attributes := [Db.faHiddenCol];
{$endif}
  end;

  // get all (new) MDX index defs
  TempMdxFile := FDbfFile.MdxFile;
  for I := 0 to FDbfFile.IndexNames.Count - 1 do
  begin
    // is this an MDX index?
    lIndexName := FDbfFile.IndexNames.Strings[I];
    if FDbfFile.IndexNames.Objects[I] = TempMdxFile then
      if FIndexDefs.GetIndexByName(lIndexName) = nil then
        TempMdxFile.GetIndexInfo(lIndexName, FIndexDefs.Add);
  end;
end;

procedure TDbf.InitFieldDefs;
begin
  InternalInitFieldDefs;
end;

procedure TDbf.InitDbfFile(FileOpenMode: TPagedFileMode);
const
  FileModeToMemMode: array[TPagedFileMode] of TPagedFileMode =
    (pfNone, pfMemoryCreate, pfMemoryOpen, pfMemoryCreate, pfMemoryOpen,
     pfMemoryCreate, pfMemoryOpen, pfMemoryOpen);
begin
  FDbfFile := TDbfFile.Create;
  if FStorage = stoMemory then
  begin
    FDbfFile.Stream := FUserStream;
    FDbfFile.Mode := FileModeToMemMode[FileOpenMode];
  end else begin
    FDbfFile.FileName := FAbsolutePath + FTableName;
    FDbfFile.Mode := FileOpenMode;
  end;
  FDbfFile.AutoCreate := false;
  FDbfFile.DateTimeHandling := FDateTimeHandling;
  FDbfFile.OnLocaleError := FOnLocaleError;
  FDbfFile.OnIndexMissing := FOnIndexMissing;
end;

procedure TDbf.InternalInitFieldDefs; {override virtual abstract from TDataset}
var
  MustReleaseDbfFile: Boolean;
begin
  MustReleaseDbfFile := false;
  with FieldDefs do
  begin
    if FDbfFile = nil then
    begin
      // do not AutoCreate file
      InitDbfFile(pfReadOnly);
      FDbfFile.Open;
      MustReleaseDbfFile := true;
    end;
    GetFieldDefsFromDbfFieldDefs;
    if MustReleaseDbfFile then
      FreeAndNil(FDbfFile);
  end;
end;

procedure TDbf.InternalInitRecord(Buffer: PChar); {override virtual abstract from TDataset}
var
  pRecord: pDbfRecord;
begin
  pRecord := pDbfRecord(Buffer);
  pRecord^.BookmarkData.PhysicalRecNo := 0;
  pRecord^.BookmarkFlag := bfCurrent;
  pRecord^.SequentialRecNo := 0;
// Init Record with zero and set autoinc field with next value
  FDbfFile.InitRecord(@pRecord^.DeletedFlag);
end;

procedure TDbf.InternalLast; {override virtual abstract from TDataset}
begin
  FCursor.Last;
end;

procedure TDbf.DetermineTranslationMode;
var
  lCodePage: Cardinal;
begin
  lCodePage := FDbfFile.UseCodePage;
  if lCodePage = GetACP then
    FTranslationMode := tmNoneNeeded
  else
  if lCodePage = GetOEMCP then
    FTranslationMode := tmSimple
  // check if this code page, although non default, is installed
  else
  if DbfGlobals.CodePageInstalled(lCodePage) then
    FTranslationMode := tmAdvanced
  else
    FTranslationMode := tmNoneAvailable;
end;

procedure TDbf.InternalOpen; {override virtual abstract from TDataset}
const
  DbfOpenMode: array[Boolean, Boolean] of TPagedFileMode =
     ((pfReadWriteOpen, pfExclusiveOpen), (pfReadOnly, pfReadOnly));
var
  lIndex: TDbfIndexDef;
  lIndexName: string;
  LanguageAction: TDbfLanguageAction;
  doCreate: Boolean;
  I: Integer;
begin
  // close current file
  FreeAndNil(FDbfFile);

  // does file not exist? -> create
  if ((FStorage = stoFile) and 
        not FileExists(FAbsolutePath + FTableName) and 
        (FOpenMode in [omAutoCreate, omTemporary])) or
     ((FStorage = stoMemory) and (FUserStream = nil)) then
  begin
    doCreate := true;
    if Assigned(FBeforeAutoCreate) then
      FBeforeAutoCreate(Self, doCreate);
    if doCreate then
      CreateTable
    else
      exit;
  end;

  // now we know for sure the file exists
  InitDbfFile(DbfOpenMode[FReadOnly, FExclusive]);
  FDbfFile.Open;

  // fail open?
{$ifndef FPC}  
  if FDbfFile.ForceClose then
    Abort;
{$endif}    

  // determine dbf version
  case FDbfFile.DbfVersion of
    xBaseIII: FTableLevel := 3;
    xBaseIV:  FTableLevel := 4;
    xBaseVII: FTableLevel := 7;
    xFoxPro:  FTableLevel := TDBF_TABLELEVEL_FOXPRO;
  end;
  FLanguageID := FDbfFile.LanguageID;

  // build VCL fielddef list from native DBF FieldDefs
(*
  if (FDbfFile.HeaderSize = 0) or (FDbfFile.FieldDefs.Count = 0) then
  begin
    if FieldDefs.Count > 0 then
    begin
      CreateTableFromFieldDefs;
    end else begin
      CreateTableFromFields;
    end;
  end else begin
*)
//    GetFieldDefsFromDbfFieldDefs;
//  end;

{$ifdef SUPPORT_FIELDDEFS_UPDATED}
  FieldDefs.Updated := False;
  FieldDefs.Update;
{$else}
  InternalInitFieldDefs;
{$endif}

  // create the fields dynamically
  if DefaultFields then
    CreateFields; // Create fields from fielddefs.

  BindFields(true);

  // create array of blobstreams to store memo's in. each field is a possible blob
  FBlobStreams := AllocMem(FieldDefs.Count * SizeOf(TDbfBlobStream));

  // check codepage settings
  DetermineTranslationMode;
  if FTranslationMode = tmNoneAvailable then
  begin
    // no codepage available? ask user
    LanguageAction := laReadOnly;
    if Assigned(FOnLanguageWarning) then
      FOnLanguageWarning(Self, LanguageAction);
    case LanguageAction of
      laReadOnly: FTranslationMode := tmNoneAvailable;
      laForceOEM:
        begin
          FDbfFile.UseCodePage := GetOEMCP;
          FTranslationMode := tmSimple;
        end;
      laForceANSI:
        begin
          FDbfFile.UseCodePage := GetACP;
          FTranslationMode := tmNoneNeeded;
        end;
      laDefault:
        begin
          FDbfFile.UseCodePage := DbfGlobals.DefaultOpenCodePage;
          DetermineTranslationMode;
        end;
    end;
  end;

  // allocate a record buffer for temporary data
  FTempBuffer := AllocRecordBuffer;

  // open indexes
  for I := 0 to FIndexDefs.Count - 1 do
  begin
    lIndex := FIndexDefs.Items[I];
    lIndexName := ParseIndexName(lIndex.IndexFile);
    // if index does not exist -> create, if it does exist -> open only
    FDbfFile.OpenIndex(lIndexName, lIndex.SortField, false, lIndex.Options);
  end;

  // parse filter expression
  try
    ParseFilter(Filter);
  except